% VAX-11 Librarian V04-00`VމK{ 4 """G(uAPPTDTC_COMMONCNVT_TO_MMDDYY COMDTC_COMMON'DANYDATMUNDAYDEFCENTRY_COMMONDHELPVAX DTCALCDOW4DTCAT6 DTCDATCVTH DTCDATINCP DTCDSPMTHWDTCICOMDUDTCIDATEY DTCMTHNAM\ DTCRDAPPTf DTCTIMCVTlDTCVAXDTCXIDATE_COMMON} DTC_PRINT ESCDTC_COMMONFNSCANINCCENT_COMMONMENUMISCHYMONTHSHRINKSTRIPTIMINCWEEKYEARGABYRINCCENT_COMMONMENUMISCHYMONTHSHRINKSTMTFUNC_COMMONSTRIPTIMINCWEEKYEARFNSCANYEAR 8lrHc-----------------------------------------------------------------------cYc Daily Appointment subroutinect"c part of Mitch Wyle's DTC programc, c Input: Hc line - 72 bytes; Format: D [mmddyy [hh:mm>HH:MM [appointment]]]ct c Output:Lc display screen (see below))cHc-----------------------------------------------------------------------CCHc Modified 850314, CG, to write day-of-week to daily-appointment screen,Cc and note current time if current day displayed (reverse video)dIc Modified 19850802, CG, to write full date as well, and handle both new-l&c and old-format appointment files. SUBROUTINE day ! (line) c Declarations:r) include 'Dtc_source(comdtc_Common)/list'-* include 'Dtc_source(apptdtc_Common)/List') include 'Dtc_Source(escdtc_Common)/list'. character*100 apstr Character*50 Double_Quotee? + /' " " " " " "'/e' byte appnt(icmln) ! appointment string); byte temp(2), ll, ln1, ! temporary string converting array+ 1 ap1, byte blot/26/ ! ^Z, for entry from display integer id, idr ! Julian Day integer im, imr ! Julian Month integer iye, iyr ! Julian Yeark5 integer idx, imx, iyx, isx ! copies for calling DANYo integer eofflg @ real*8 daylist(7) / ' Sun', ' Mon', ' Tues', ! uses A6 fmt@ 1 'Wednes', ' Thurs', ' Fri', ' Satur' / ! 'day' is in format character*9 mthlist(12)7 1 /' January', ' February', ' March', ' April',,7 2 '  May', ' June', ' July', ' August', 7 3 'September', ' October', ' November', ' December'/- equivalence (line, ln1), (apstr, appnt, ap1)s include 'stmtfunc.for/nolist' c Initialize: 0 if ((ln1 .and. ucmask) .eq. 'D') ! leave = or * 1 call shrink(1, ifnb, lnb) + call dtcdatcvt(3) ! Pick off a date value) im=idmo id=iddy iye=ibigyrl? call dtcalcdow (isx, imx, im, iye) ! Get day-of-week for B/O/M)6 idx = mod (id + isx - 2, 7) + 1 ! Calc current d/o/w1 call dtcidate(imr, idr, iyr) ! Get today's dateO/ if ((im .eq. imr) .and. ! if current = today,Q- 1 (id .eq. idr) .and. ! flag current timeO2 2 (iye .eq. iyr)) then ! Displaying current dayA scnds = amax1(secnds(0.), 28801.) ! Get current time (>8 AM)TD ihalf = mod(ifix(scnds/1800.), 48) ! current half-hour (orig 0)$ ihour = ihalf/2 ! Current hour5 ihalf = ihalf - (ihour*2) ! 0 or 1 for half-hourT elseO& ihour = 0 ! Set non-match value endifKc ************************** Move the cursor to top of screen and clear it,=9c ************************** set up appointments display:) write(iterm,4) esc,homescrn, esc,clrscrn1 4 format('+', 4a, $) write(iterm,5) '+', esc,dhdw1,( 1 daylist(idx), mthlist(im), id, ibigyr8 5 format(3a,'Schedule - ', a6,'day, ', a9, i3, ',', i5) write(iterm,5) ' ', esc,dhdw2,I( 1 daylist(idx), mthlist(im), id, ibigyr Do i=8,16 If ( i .gt. 12 ) then j = i - 12 Elser j = i2 End Ifk6 if (i .ne. ihour) then ! Check for highlighting write(iterm,6) j 6 format(x,i2,':00 -') write(iterm,7) j 7 format(x,i2,':30 -')$ else ! must be current hour, if (ihalf .eq. 0) then ! Check which half5 write(iterm,96), esc,revattr, j, esc,resetvattr write(iterm,7) j else write(iterm,6) j5 write(iterm,97), esc,revattr, j, esc,resetvattr endif( 96 format (x, 2a, i2,':00 -', 2a)( 97 format (x, 2a, i2,':30 -', 2a) endif end doH4 if (ihour .ge. 17) then ! Highlight 'Evening' line1 write(iterm,98), esc,revattr, esc,resetvattr, else ! Includes display other than today write(iterm,9) end if ' 9 format(x, 'Evening:', /, x, 78('='))D1 98 format(x, 2a, 'Evening: ', 2a, /, x, 78('='))4c ******************* Screen has now been displayed,Ec ******************* now check rest of line for time and appointment 3 if (ln1 .ne. 0) then ! More characters available? iht = 80 ! rc Date munger function c part of DTC-c- Subroutine datmun(line) Byte line(84),work(84)- byte l1,l2,l3c c function:n+c edit a line starting with a date of form c mm/dd/yy'c into one starting with a date of formec mmddyyc9-c also if the line starts with a date of formr c dd-mmm-yydc edit back into mmddyy from4c that form. Leaves whatever follows the date alone.4c Added for DTC to not have to use such a crock date4c format as the original; too hard to use otherwise.3c if mmddyy form already exists, leave line alone.e do 1 n=1,6r if(line(n).eq.'/')goto 100 c 100 is for mm/dd/yy form if(line(n).eq.'-')goto 200ec 200 is for dd-mmm-yy form 1 continue?c if format looks OK already, just return and leave line alone.C Returnl 100 continue'c handle mm/dd/yy and turn into mmddyyo if(line(2).eq.'/') then work(1)='0' work(2)=line(1) k=3 elsei work(1)=line(1) work(2)=line(2) k=4 end ifr if(line(k+1).eq.'/')thenw work(3)='0' work(4)=line(k) kk=k+2o else  work(3)=line(k) work(4)=line(k+1) kk=k+3a end if work(5)=line(kk)  work(6)=line(kk+1)n5c set up pointers to next element of line (i.e., kkk)ec for copy of rest of stuff. kkk=kk+2 goto 300d 200 continue'c handle dd-mmm-yy and turn into mmddyya if(line(2).eq.'-')theno work(3)='0' work(4)=line(1) k=3 else. work(3)=line(1) work(4)=line(2) k=4 end ifw work(5)=line(k+4) work(6)=line(k+5) kkk=k+65c now have pointers, but month needs to be filled in. 3c note we assume year always is entered as 2 digitsJc and month is 3 chars...e if(line(k+3).ne.'-')thend work(1)=0(c zero stuff to pass if not 3 char month work(2)=0 goto 300l end ifu kk=k+3n do 220 n=k,kk nn=line(n)ec mask off 32 (dec) bit toc make letters uppercase nn=nn.and.223 line(n)=nnt 220 continue l1=line(k)m l2=line(k+1)r l3=line(k+2)ec decode months the hard way work(1)='0' work(2)='0' IF(L1.EQ.'J'.AND.L2.EQ.'A')THEN WORK(2)='1' GOTO 300 ELSE IF(L1.EQ.'F')THENr WORK(2)='2'e GOTO 3003 ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'R')THENa WORK(2)='3'r GOTO 300% ELSE IF(L1.EQ.'A'.AND.L2.EQ.'P')THENy WORK(2)='4': GOTO 3003 ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'Y')THENd WORK(2)='5' GOTO 3003 ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'N')THEN WORK(2)='6'o GOTO 3003 ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'L')THEN- WORK(2)='7'- GOTO 300% ELSE IF(L1.EQ.'A'.AND.L2.EQ.'U')THENv WORK(2)='8' GOTO 300 ELSE IF(L1.EQ.'S')THENp WORK(2)='9' GOTO 300 ELSE IF(L1.EQ.'O')THEN WORK(1)='1'r GOTO 300 ELSE IF(L1.EQ.'N')THENl WORK(1)='1't WORK(2)='1' GOTO 300 ELSE IF(L1.EQ.'D')THENn WORK(1)='1'a WORK(2)='2'r GOTO 300 ELSE WORK(1)=0 WORK(2)=0 #C UNRECOGNIZED MONTH -- SCREW IT...  END IF1 goto 300 300 continuec common clean-up & return do 310 n=7,84 work(n)=line(kkk) if(kkk.lt.84)kkk=kkk+1 310 continue do 320 n=1,84320 line(n)=work(n)t,c copies edited string back for further work return! endwweter7c Check for default century, add default if not present" if (iy .lt. 100) iy = iy + icntryCC Take care of leap years:C# lpyear = 0 ! Assume "common" year IF (islpyr(IY)) 1 THEN- MONTHS(2)=29 ! length February in Leap year: if (im .gt. 2) lpyear = 1 ! Add one to BOM DOW after Feb ELSE! MONTHS(2)=28 ! .. "common" year END IF(c --- If ( iy .gt. 1900 ) iy = rHc-----------------------------------------------------------------------cyc Help subroutinec "c part of Mitch Wyle's DTC programc c Inputs: c Nonedcp c Output: c display screen (see below)cwHc-----------------------------------------------------------------------ca SUBROUTINE dhelpr) include 'Dtc_source(comdtc_Common)/list'y) include 'Dtc_source(escdtc_Common)/list'ec,c integer iterm/6/c byte esc/"033/ byte buf(79)tca c Initialize:ecn*c iterm = 6 ! Output terminal unit number c esc = "033 call dtcat(1,1)9 write(iterm,91) esc,homescrn, esc,clrscrn ! clear screenuA write(iterm,1) '+', esc,dhdw1, ' D T C - Desk Top Calendar'3A write(iterm,1) ' ', esc,dhdw2, ' D T C - Desk Top Calendar'ace 1 format(40a) 91 format('+',4a, $)p@ Open (unit=1,file='SYS$HELP:DTC.HLP',READONLY,form='FORMATTED', 1 status='OLD', err=9) Do i=1, 22  Read(1,4,end=5) ibln, buf if (ibln .ne. 0) then$ write (iterm,6) (buf(j), j=1,ibln) else= write (iterm,6) end if4 end do cI 4 format(q,100a1) 6 format(x,100a1)c $ 5 close(unit=1) ! Read end-of-file return cn 9 write(iterm, 99) 3 99 format(' Help file SYS$HELP:DTC.HLP not found')8 endwwcc *** Removed loop, 850729=c --- Do 1 i=1,(im-1) ! Add all previous months' days to sum#c --- idays = idays + months(i)c --- 1 Continue+c *** Incorporated in initial value of iday0c --- Now add two because 1/1 <$s$ SUBROUTINE dtcalcdow (ib,il,im,iyx)Hc-----------------------------------------------------------------------cc DTCALCDOW subroutinec"c part of Mitch Wyle's DTC programc c Inputs: c im - month (number 1-12)c iy - year (number 0-9999)c c Outputs:,c ib - integer corresponding to day of week$c on which the month begins (1-7)#c il - length of the month in dayscGc Modified 850117 by CG because it thought New Years 1985 was on Monday:c when it ! really was on Tuesday (not counting intervening;c leap years between 1982 and current as having 366 days).(Bc Modified 850724 by Glenn Everhart to work for years between 1900;c and 1982 (formerly thought all intervening years started c on Friday)d@c Modified 850726 by CG to simplify days-since-base calculation.7c NOTE: Has been reworked to calculate all dates AS IFt8c the Gregorian Calendar had been in effect since AD 1,4c and that the Gregorian correction for 100 and 4001c will be v "alid indefinitely (the 1928 Episcopal 9c Book of Common Prayer indicates this is valid at least'9c until AD (or CE) 8400, but I don't think I, or anybodyg9c reading this code within the forseeable future will ber:c around to verify whether it does or doesn't!), see note>c just before IDAYS computation. It will also try to compute?c if a negative year is input (i.e., BC) but probably won't bee>c valid since there was no year zero. If any calendar phreak<c wants to figure it out for th #e Julian calendar, have fun,=c just keep in mind that the Gregorian superseded the JulianiCc at different times and in different ways in different localitiesx:c (October 4, 1582 was followed by October 15 in CatholicAc countries, and another "long sleep" occurred in September 1752 7c in English-speaking realms, but apparently in Swedenr1c the change was effected by omitting Leap Years(&c until the calendar got back in sync<c (there is a story of a man who didn't celebrate his first:c $ birthday until he was sixty years old, leaving Frederic9c of Pirates of Penzance with little to complain about)!i;c Russia, Romania, Greece and Turkey did not convert until c the twentieth century.gc :c P.S.: 4th parameter (input year) is no longer modified.coFc Modified 850729 by CG - Get rid of loop that added number of days of2c each month --- why sum a sequence of constants?Ac Modified 850802 by CG - renamed from DANY to DTCALCDOW, removed'4c default century and previously comm%ented-out codeIc Modified 850809 by CG - Insure IB output in range 1..7: negative values.9c (from negative year input) caused DTCDSPMTH to zap its Cc character arrays and display some verrry strange-looking months!Oc3Hc-----------------------------------------------------------------------c Declarations:F9c Base value for IDAYS, day-of-week for January 1, AD 1 ! parameter idow = 2L integer im ! Julian MonthQ integer iyx, iy ! Julian YearO+ integer lpyear ! Define additive v&ariable< integer months(12) ! array of months and the number of daysA 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ ! in each one36 integer bomdow(12) ! array of months containing d/o/wA 1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 / ! of first day of month=B include 'Dtc_Source(stmtfunc_Common)/list' ! Need ISLPYR function c Begin code iy = iyx ! Copy parameter c Take care of leap years:# lpyear = 0 ! Assume "common" yeark if (islpyr(iy)) 1 then5 months(2) = 29 2! length of February in leap yearo= if (im .gt. 2) lpyear = 1 ! Add one to BOM DOW after Feb else& months(2) = 28 ! .. "common" year end if>c Rather than add up all of the days since January First, AD 1Rc (which would have been a Monday had the Gregorian calendar been in effect then),Gc we note that the day of week of 1 January advances by 1 day per year,Fc plus another day the year AFTER a leap year, etc, therefore just addJc values of years, leap years, century years, etc,(uvr SUBROUTINE dany(ib,il,im,iyx)Hc-----------------------------------------------------------------------cc Dany subroutine ce"c part of Mitch Wyle's DTC programc c Inputs: c im - month (number 1-12)m!c iy - year (either 1983 or 83)tc c Outputs:,c ib - integer corresponding to day of week$c on which the month begins (1-7)#c il - length of the month in daysCctGc Modified 850117 by CG because it thought New Years 1985 was on Mondayi:c when it reall )y was on Tuesday (not counting intervening;c leap years between 1982 and current as having 366 days).Bc Modified 850724 by Glenn Everhart to work for years between 1900;c and 1982 (formerly thought all intervening years startede c on Friday)o@c Modified 850726 by CG to simplify days-since-base calculation.7c NOTE: Has been reworked to calculate all dates AS IFl8c the Gregorian Calendar had been in effect since AD 1,4c and that the Gregorian correction for 100 and 4001c will be valid i *ndefinitely (the 1928 Episcopalh9c Book of Common Prayer indicates this is valid at least 9c until AD (or CE) 8400, but I don't think I, or anybody*9c reading this code within the forseeable future will be:c around to verify whether it does or doesn't!), see note>c just before IDAYS computation. It will also try to compute?c if a negative year is input (i.e., BC) but probably won't bey>c valid since there was no year zero. If any calendar phreak<c wants to figure it out for the Juli +an calendar, have fun,=c just keep in mind that the Gregorian superseded the Julian Cc at different times and in different ways in different localitiesb:c (October 4, 1582 was followed by October 15 in CatholicAc countries, and another "long sleep" occurred in September 1752 7c in English-speaking realms, but apparently in Sweden)1c the change was effected by omitting Leap Yearsd&c until the calendar got back in sync<c (there is a story of a man who didn't celebrate his first:c birth,day until he was sixty years old, leaving Frederic9c of Pirates of Penzance with little to complain about)!);c Russia, Romania, Greece and Turkey did not convert until0c the twentieth century. ci:c P.S.: 4th parameter (input year) is no longer modified.c-Dc Modified 850729 by CG - Get rid of loop that add number of days of2c each month --- why sum a sequence of constants?cMHc-----------------------------------------------------------------------cscpc Declarations:yc9c -Base value for IDAYS, day-of-week for January 1, AD 1 !, parameter idow = 2eN include 'Dtc_Source(defcentry_Common)/list' ! Common parameter with DTCDATCVT integer im ! Julian Month  integer iyx, iy ! Julian Yearc+ integer lpyear ! Define additive variableb< integer months(12) ! array of months and the number of daysA 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ ! in each one 6 integer bomdow(12) ! array of months containing d/o/wA 1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 / .! of first day of montheB include 'Dtc_Source(stmtfunc_Common)/list' ! Need ISLPYR function iy = iyx ! Copy parametere7c Check for default century, add default if not presentl" if (iy .lt. 100) iy = iy + icntryCrC Take care of leap years:Ct# lpyear = 0 ! Assume "common" year, IF (islpyr(IY)) 1 THEN - MONTHS(2)=29 ! length February in Leap year: if (im .gt. 2) lpyear = 1 ! Add one to BOM DOW after Feb ELSEw! MONTHS(2)=28 ! .. "common" years END IF(c -- /- If ( iy .gt. 1900 ) iy = iy - 19004c --- If ( ( iy .eq. 01 ) .and. ( im .eq. 1 ) ) then!c --- jan 1,1901 was a tuesday...x c --- ib = 3 c --- il = 31 c --- return* c --- End If>c Rather than add up all of the days since January first, AD 1$c (which would have been a Tuesday),Cc we note that day of week of 1 January advances by 1 day per year,=Fc plus another day the year after a leap year, etc, therefore just addJc values of years, leap years, century years, etc, modulo 7, to figure0 out2c day of week of the January we are interested in.. itemp = iy - 1 ! not including current year) idays = idow ! Day of week of 1/1/0001a# 1 + itemp ! plus number of years + 2 + (itemp/4) ! plus number of leap years2& 3 - (itemp/100) ! less even hundreds3 4 + (itemp/400) ! but add back even four hundredsl+ 5 + bomdow(im) ! plus day of week for BOM. 6 + lpyear ! plus 1 after March in leap yearJc *** Loop below removed, replaced by direct computation above - CG 850726c --1- If ( itemp .gt. 0 ) thenc --- Do 2 i=1,itempc --- idays = idays + 3657c --- if (mod (i, 4) .eq. 0) ! Intervening leap year? 5c --- 1 idays = idays + 1 ! Yes, count extra daymc --- 2 Continue c --- End If=c --- itemp = itemp + 2 ! No further reference - CG - 850117c cdc *** Removed loop, 850729=c --- Do 1 i=1,(im-1) ! Add all previous months' days to sumo#c --- idays = idays + months(i).c --- 1 Continue+c *** Incorporated in initial value of idayi0c -- - Now add two because 1/1/01 was a Tuesday.c --- idays = idays + 2r ib = mod ( idays , 7 )i If ( ib .eq. 0 ) ib = 7 il = months(im) return1 endwwlapp, workstr 13 format(q,a)#c copy appointment for use later... ifnb = 0 lnb = 0 ivx = 0 Do i = 1, lapp& ll = work(i) ! fetch character if (ll .gt. ' ') then3 if (ifnb .eq. 0) ifnb = i ! Flag first non-blank# lnb = i ! Flag last non-blank end if3 if (ifnb .ne. 0) the3 modulo 7, to figure out0c day of week of the month we are interested in.. itemp = iy - 1 ! not including current year) idays = idow ! Day of week of 1/1/0001# 1 + itemp ! plus number of years + 2 + (itemp/4) ! plus number of leap years& 3 - (itemp/100) ! less even hundreds3 4 + (itemp/400) ! but add back even four hundredsi+ 5 + bomdow(im) ! plus day of week for BOMn5 6 + lpyear ! plus 1 for March or later in leap yearn/ ib = mod ( idays , 7 ) ! Find day of week 0:6nD if (ib .le. 0) ib = ib + 7 ! In case IY was negative (Sun is day 1)0 il = months(im) ! Length of the current month endwwixx = 1, idmx. write(1,14) iye,im,id,ihtxx,apstr(1:ivx)# if ((ihtxx/10)*10 .eq. ihtxx) 1 then9 ihtxx=ihtxx+3 ! IHT is even hour, go to next half hour else> ihtxx=ihtxx+7 ! IHT is a half hour ... make up to next hour end if end do 14 format(i4.4,2i2.2,i3.3,x,a) 9876 close(1) End If- else ! E5xE`s! subroutine dtcat(ic,ir) ! x, y c 7 include 'Dtc_Source(comdtc_Common)/list' ! Need ITERM ) include 'Dtc_Source(escdtc_Common)/list'OcIc byte esc /"033/c integer iterm/6/ c esc = "033 c iterm = 6g+c write(iterm,1) esc,'<' ! Done in DTCVAX,c 1 format(x,2a1,$) ce- write(iterm, 2, err=3) esc,'[',ir,';',ic,'H'l@ 2 format(x,2a1,i2.2,a1,i3.3,a1,$) ! Max rows is 2-digit numbercn return c ( 3 write (iterm,10) esc,homescrn, ir, icB 10 format('+', 2a, 'Error in DTCAT, row/col =', 2z5.4, ' (hex).') endwwe this occasion to-c add the record to everyone's calendar file. close(2)4 Open (unit=2, file=work(istart), status='UNKNOWN',0 1 form='FORMATTED', carriagecontrol='LIST',! 2 access='APPEND', err=1119) ihtxx=iwht do ixx = 1, idmx0 write(2,14) iwy,iwm,iwd,ihtxx,apstr(1:ivx)( if ((ihtxx/10)*10 .eq. ihtxx) then< ihtxx=ihtxx+3 ! iht is an even hour ... add the half hour else> ihtxx=ihtxx+7 ! iht is a ha 71s>c Date conversion function (part of DTC), derived from DATMUN,Bc except decodes the values directly into DEFDAT and shrinks LINE,9c rather than schlep LINE back and forth to kingdom come.5c ;c Modified 850422, CG, to restrict values of month/day/yearoc1Fc modified 850325, 850726 & 850731, CG, to allow any of the following:Dc d{d}/m{m}/{y}y, d, dd, dmm, ddmm, dmmyy, ddmmyy, dmmyyyy, ddmmyyyyc for D or W functions2c m{m}/{y}y, m, mm, myy, mmyy, mmyyyy, myyyy for M8c y, yy, yyy, yyyy for Ypcr-c plus dd-mon-yy, dd-mm-yy, dd-xii-yy formatstc) c function:p.c Convert a line starting with a date of form/c mmddyy OR mm/dd/yy OR dd-mon-yy OR dd-romn-yycEc to binary equivalents, and remove from line, copying binary values c to DEFDAT in common. ce*c Leaves whatever follows the date alone.5c Added for DTC to not have to use such a crock date5c format as the original; too hard to use otherwise. ' Subroutine dtcdatcvt (nf) ! (line,nf)ecd i9mplicit nonecf* integer nf ! Number of fields expectedc) include 'Dtc_Source(comdtc_Common)/list'c> byte nb, l1, l2, l3, l4, lxx(4), work(icmln), tb6(6), ln1 !,c< integer lm(12) ! lengths of months (30 days hath Sept ...)3 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/c7 integer minln(12) ! Min chars to recognize month names' 1 /2, 1, 3, 2, 3, 3, 3, 2, 1, 1, 1, 1/I character*4 rch, ! Decode month names, or European style w/ Roman months< 1 mab(12) / 'JANU', 'FEBR:', 'MARC', 'APRI', 'MAY ', 'JUNE',7 2 'JULY', 'AUGU', 'SEPT', 'OCTO', 'NOVE', 'DECE'/,-< 3 rom(12) / 'I ', 'II ', 'III ', 'IV ', 'V ', 'VI ',6 4 'VII ', 'VIII', 'IX ', 'X ', 'XI ', 'XII '/5 integer i, k, kkk, n, nn, ix, ixyr, ixmo, ixdy, nfd,- 1 ifnb, lnb, lcount6 logical longyr ! If year entered as 3 chars or more, integer*2 iwk(42), lw1 ! 2 chars at a timec integer*4 ll1 equivalence (line, ln1, lw1), 1 (ll1, rch, lxx), (work, iwk)c  integer icvt10,; icurm byte ichu+ include 'Dtc_Source(stmtfunc_Common)/list'iK icvt10(icur, ich) = (icur * 10) + icvtbn1(ich) ! conversion function staged c Begin code7 longyr = .false. ! set default of century calculation .c Initialize default values for omitted fields& ixyr = ibigyr ! Copy current values ixmo = idmo ! from common ixdy = iddy7 if (numeric(ln1)) then ! Dates must start with numberR* work(1) = ln1 ! Copy first character2 ix = icvtbn1(ln1) ! Compute value <on the flyc2 do n = 2, (nf * 2) + 2 ! Allow [mm][dd][yyyy]cr( l1 = line(n) ! Copy current character, if (l1 .eq. '/') ! Field separators: slash% 1 go to 100 ! for mm/dd/yy forml if (l1 .eq. '-') ! .. dash& 1 go to 200 ! for dd-mmm-yy form' if ((l1 .eq. ':') .or. (l1 .eq. '>'))< 1 go to 999 ! hour-string first, return default values) if (.not. numeric(l1)) ! anything else:L 1 go to 300 ! mmddyy, minus some characters, fake whatever is required= work(n) = l1 ! Don't recopy, ix = icvt10(ix, l1) ! continue conversion end do-9 n = (nf * 2) + 3 ! Set shrink value if no delimiterr go to 300 ! Go convert it2 else if ((ln1 .eq. '+') .or. (ln1 .eq. '-')) then& k = incmod ! Save current value/ call dtcdatinc ! Convert incremental dateo incmod = k ! Restoret else if (ln1 .eq. '=') then3 kkk = 1 ! Place holder, strip only, date n/ce go to 9500 end if ! (don't want to reformat who>le file) go to 999 ! All done here1c handle mm/dd or mm/dd/yy{yy} (for D, W, M or Y)ac or mm/yy{yy} (for M or Y)8; 100 continue ! Here for '/' encountered in first scan loop1& k = n + 1 ! next character to look at l1 = line(k)o. if (.not. numeric(l1)) go to 300 ! nnnn/x ???9 ixmo = ix ! First field is always month in "/" notationa( ix = icvtbn1(l1) ! Start 2nd conversion$ do n = k + 1, 20 ! should be plenty! l1 = line(n) ! get characterf0 if (l1 .eq. '/') go t?o 110 ! Found second /3 if (.not. numeric(l1)) go to 120 ! End of scant" ix = icvt10(ix, l1) ! convert end do0 n = 21 ! Set it 120 if (nf .eq. 3) then" ixdy = ix ! 2nd field is day else ixyr = ix ! .. yeare longyr = ((n - k) .gt. 2) end if go to 900= 110 l1 = line(n+1) ! Found 2nd slash, check for third fields/ if (.not. numeric(l1)) go to 120 ! left field!d k = n + 1 ixdy = ix ! 2nd has to be day2 ixyr = icvtbn1(l1) ! Start 3rd c@onversion (year)& do n = k + 1, 20 ! get more numerics l1 = line(n)d% if (.not. numeric(l1)) go to 910  ixyr = icvt10(ixyr, l1) end do n = 21 ! mark next character go to 910 ! set for SHRINKt,c handle dd-mon-yy, dd-mm-yy, or dd-roman-yy/ 200 continue ! Here for '-' in first scan loopr% ixdy = ix ! Copy converted day fieldtB rch = ' ' ! initialize for alpha month name, or Roman numerals k = n + 1 ! next char after "-" l1 = line(k)f2 if A(numeric(l1)) then ! European format dd-mm-yy- ixmo = icvtbn1(l1) ! go for it directly  do n = k + 1, 20R l1 = line(n)" if (.not. numeric(l1)) go to 210 ixmo = icvt10(ixmo, l1) end doh n = 21u else if (alpha(l1)) then.? lxx(1) = l1 .and. '5F'X ! Set first char for name or romanf lcount = 1o4 do nn = k + 1, k + 6 ! should find "-" by then l1 = line(nn) + if (l1 .eq. '-') go to 230 ! Start searchc1 if (.not. alpha(l1)) gBo to 230 ! also terminated7 if (lcount .lt. 4) then ! room for at least one morev lcount = lcount + 1e3 lxx(lcount) = l1 .and. '5F'X ! Copy charactera end if end dov nn = k + 6n 230 continue-& do i = 1, 12 ! Loop over months; if (rch .eq. rom(i)) go to 250 ! Found match in roman setf if (lcount .ge. minln(i)) then. if (rch(1:lcount) .eq. mab(i)(1:lcount))+ 1 go to 250 ! Found match in alpha namesY end ifLC Note: last two IF statemenCts above replace original horrendous sequence ofMc IF-THEN-ELSEs to see if month was J then A, or F, or M then A then R, etc ! end do'c Fell out of loop, leave current monthi@ go to 300 ! Unknown month or roman seq, back up before "-"( 250 ixmo = i ! iwk(1) = icvtbcd(i) n = nn ! Accept characters* else ! "-" followed by non alphanumeric go to 300 end ifl5 210 if (l1 .ne. '-') go to 900 ! See if year follows1 k = n + 1 l1 = line (k)6 if (.Dnot. numeric(l1)) go to 910 ! First dash is left ixyr = icvtbn1(l1)O do n = k + 1, 30e l1 = line (n)% if (.not. numeric(l1)) go to 910h ixyr = icvt10(ixyr, l1) end doy n = 3110 910 longyr = ((n - k) .gt. 2) ! Set logic value go to 900/ 300 continue ! Short string found, fix it upo, nfd = n/2 ! Number of 2-char groups found> longyr = (nfd .gt. nf) ! check for default or forced centuryJ if ((n .and. 1) .eq. 0) then ! Example: n = 5 for 4 charsE found (0 mod 2)5 work(1) = '0' ! Force even number of charactersp do i = 2, n. work(i) = line(i - 1) ! Shift line over by 1 end do0 end if+9 go to (310, 320, 330) nf ! Dispatch on # expected fieldse go to 900 ! Bad value ???$ 310 ixyr = ix ! take year: Y [yy] go to 900 ! End case # 320 ixmo = icvtbin(iwk(1)) ! M mm 2 if (nfd .eq. 2) ixyr = icvtbin(iwk(2)) ! M {m}myy3 if (nfd .eq. 3) ixyr = mod(ix, 10000) ! M {m}myyyy! go to 900 ! End casei; 330 if (nFfd .eq. 1) ixdy = icvtbin(iwk(1)) ! D {d}d {only} % if (nfd .ge. 2) then ! D [mm]dd[yy]r& ixmo = icvtbin(iwk(1)) ! D {m}mdd& ixdy = icvtbin(iwk(2)) ! D {m}mdd end if4 if (nfd .eq. 3) ixyr = icvtbin(iwk(3)) ! D {m}mddyy5 if (nfd .eq. 4) ixyr = mod(ix, 10000) ! D {m}mddyyyy* 900 continue ! common clean-up & return> if ((ixyr .lt. 100) .and. (.not. longyr)) ! Check for 1-99 AD= 1 ixyr = ixyr + ((ibigyr/100)*100) ! add "current" century if (islpyr(ixyr)) 1 then$  lm(2) = 29 ! Set for Leap Years else)* lm(2) = 28 ! reset for "common" years end ifI! ibigyr = ixyr ! Explicit year/ idmo = min0(max0(ixmo, 1), 12) ! Limit values * iddy = min0(max0(ixdy, 1), lm(idmo)) ! ..3 kkk = n - 1 ! Change index of next char to counti* 950 idyr = mod(ibigyr, 100) ! Set value if (kkk .gt. 0): 1 call shrink (kkk, ifnb, lnb) ! Unload the stuff we used$ 999 return ! Miscellaneous exits endww', 2a, 'Error in DTCAT, row/col =', 2z5.4CDATCVT"@t PHIL DTCDATINC"]Ut PHIL DTCDSPMTH!#u PHIL DTCIDATE! pu PHIL DTCICOMD"G>u PHIL DTCMTHNAM"`Lv PHIL DTCRDAPPT" bv PHIL DTCTIMCVT@ޫv PHIL DTCVAX" !w PHIL DTC_PRINTx),a2)) endww. numeric(l1)) go to 910 V`#u$ subroutine dtcidate (imr, idr, iyr)c,Dc Testing aid for DTC - allows for phony value of current date to be1c returned to caller, for verifying displays, etc3c*c Calling sequence - same as Fortran IDATEcl) include 'Dtc_Source(comdtc_Common)/list' , include 'Dtc_Source(dtcxidate_Common)/list', include 'Dtc_Source(defcentry_Common)/list'c : if (xim .eq. 0) then ! Assumes linker initializes to zero call idate (xim, xid, xiy)r+ xibgyr = icntry + xiy ! Set long value  end ifn imr = xim idr = xid iyr = xibgyr  Return  endww ! Shift line over by 1 end do end if9 go to (310, 320, 330) nf ! Dispatch on # expected fields go to 900 ! Bad value ???$ 310 ixyr = ix ! take year: Y [yy] go to 900 ! End case# 320 ixmo = icvtbin(iwk(1)) ! M mm2 if (nfd .eq. 2) ixyr = icvtbin(iwk(2)) ! M {m}myy3 if (nfd .eq. 3) ixyr = mod(ix, 10000) ! M {m}myyyy go to 900 ! End case; 330 if (nfd .eq. 1) ixdy = icvtbin(iwXzou subroutine dtcicomdctJc Process "I" command: if no arguments, reset dummy IDATE to current date,Cc else call dtcdatcvt to parse a date string, store those values in(c XIDATE common.) include 'Dtc_Source(comdtc_Common)/list'D, include 'Dtc_Source(dtcxidate_Common)/list', include 'Dtc_Source(defcentry_Common)/list' byte ln1! equivalence (line, ln1)6 call shrink(1, ifnb, ilnb) ! Unload command character if (ln1 .eq. 0) 1 then' call idate (xim, xid, xiy) ! Resete+ xibgyr = icntry + xiy ! Set long values. ibigyr = xibgyr ! Set values into common idmo = ximx iddy = xidm idyr = xiy  else(' call dtcdatcvt (3) ! Parse string!# xim = idmo ! Set test values xid = iddyb xiy = idyrt xibgyr = ibigyr end if  endwwnb, lnb) ! Unload the stuff we used$ 999 return ! Miscellaneous exits endwwZu! SUBROUTINE dtcmthnam (im,monthn)cHc-----------------------------------------------------------------------ce&c Subroutine dtcmthnam (formerly GABY)c"c Part of Mitch Wyle's DTC programc=3c return a string corresponding to the month numbert<c Month number contained in IM. Send back string in MONTHN.c (JANUARY for 1, etc.)dcHc-----------------------------------------------------------------------crDc Modified 850315 - Center month names in table, use mixed case [- CG%c Modified 850802 - Renamed DTCMTHNAMDcac Declarations:,c  Byte monthn(9)0Cc *** character*9 monthn ! Can't use, char params expect descriptoructHc Table of month names and numbers (centered, even lengths biased left):c  Byte months(9,14)( character*9 monthch(14)/ 'December ',6 1 ' January ', 'February ', ' March ', ' April ',6 2 ' May ', ' June ', ' July ', ' August ',6 3 'September', ' October ', 'November ', 'December ', 4 ' January '/c equivalence (months, monthch)cu1c Select the right month and fill monthn with it:dcC ALLOW FOR OVERFLOWS... IMM=IM+1o1c *** monthn = monthch(imm) ! String assignmentc  Do i=1,9 ! Byte-at-a-time Monthn(i) = months(i,imm) end do c All done.m endww if (ll .eq. 'D') 1 then incmod=1! else if (ll .eq. 'W') then incmod=2! else if (ll .eq. 'M') then incmod=3! else if (ll .eq. 'Y') then incmod=4 else3 n = n - 1 !]1v& subroutine dtcrdappt (eofflg, indflg)Mc search through appointment files for entries matching range of hash values.Lc opens files if EOFFLG set on entry. INDFLG controls whether indirect filesOc should be opened as encountered, and whether caller wants to look at indirectc entry or not:c INDFLGc -1 No processing @c 0 Normal processingc +1 Return before opening @c EOFFLG Entry Exitc -1 Initialize EOF return2c 0 Normal re-entry Normal ret^urn, valid entry/c +1 Open @ file Return for @ filename found*c Processes both old- and new-format files<c Old: yymmddhhh appt (possibly no blank between HHH & APPT)c New: yyyymmddhhhh apptCc Created 19850802, CG, using some code removed from DAY subroutine. implicit none& integer eofflg, indflg ! i/o, i only) include 'Dtc_Source(comdtc_Common)/list'=* include 'Dtc_Source(apptdtc_Common)/list'M include 'Dtc_Source(defcentry_Common)/list' ! Default century for old formate:_ character*1 nullch /0/ ! Old old files had trailing NULs# integer i, ij, lth, istrend, nunite+ include 'Dtc_Source(stmtfunc_Common)/list' c Begin codec *** type 950, irqhashnc 950 format(2z9.8)1" if (eofflg .lt. 0) ! Start scan 1 then nunit=1 close(1).0 Open (unit=nunit, file=FNAME, status='OLD',( 1 form='FORMATTED', readonly, err=99) eofflg = 0 c *** type *, ' Opened file'! end ifyBc loop back up here to continue reading and processing i`nput file: do while (eofflg .ge. 0)o 900 format(q, a) ! Read all# 901 format(3i2, i3) ! Decode old3& 902 format(i4, 2i2, i3) ! Decode new2 if (eofflg .gt. 0) ! must open indirect file 1 thene eofflg = 0c *** type 951, work(istart)c *** 951 format (' ', a) nunit = 2i close(2)4 Open (unit=nunit, file=work(istart), status='old',$ 1 form='formatted', readonly,* 2 carriagecontrol='LIST', err=1067) end ifs - read (nunit, 900, eand=400), lth, workstric *** type *, ' ', workstry$ do i = min0(lth, iwrkln), 1, -13 if ((workstr(i:i) .ne. ' ') ! Look for non-blankn5 1 .and. (workstr(i:i) .ne. nullch)) ! & non-null 2 go to 10 ! Break end do$ i = 1 ! All blank entry ??? 10 lth = i=c String is filled with blanks regardless of length of record # if (chnumeric(workstr(10:10))) 1 then ! new format/ read(workstr, 902, err=30) ihy, ihm, ihd, iht/ istart = 12 !b Index of first valid character c *** type *, ' New format' else ! Old format 30 continue ! Retry old0 read(workstr, 901, err=300) ihy, ihm, ihd, iht- ihy = ihy + icntry ! Insert current centuryo' istart = 10 ! Assume old, old formatc *** type *, ' Old format'( end if ! (workstr(10) is numeric)) if (workstr(istart:istart) .eq. ' ')o7 1 istart = istart + 1 ! Index of first valid characterc( iwkln = max0((lth - istart) + 1, 1)# istrend =c (istart + iwkln) - 1d) iaptln = max0(min0(iwkln, icmln), 1)8 if (ihm .eq. 99)n 1 thenr ihy = 9999 ! set all fields ihd = 99 iht = 999m+ if ((indflg .ge. 0) .and. (nunit .eq. 1))- 1 then-3 call fnscan(work(istart), icmln - istart + 1,t/ 1 iwkln, ij) ! Common code to check filename  if (ij .ne. 0)! 1 then ! Skip if no filetc *** type *, ' IJ = ', ij eofflg = 1 if (indflg .gt. 0)e 1 then( apptstr = workstr(idstart:istrend)& return ! DAY, STRIP want a look end if ! Found 1" end if ! non-null file-name% end if ! valid place for indirect!* else ! not filename flag in record: irchash = ihymd(ihy, ihm, ihd) ! Compute hash for recordc *** type 950, irchash  if ((irchash .ge. irqhash(1)) ' 1 .and. (irchash .le. irqhash(2))) - 2 then ! Found record within range, exit ' apptstr = workstr(istart:istrend)2c *** type *, ' Returning'# ereturn ! Break out of loop7 400 continue ! no more appointments left in file.ac *** type *, ' EOF'6 if (nunit .eq. 1) ! Which file were we reading? 1 thene" eofflg = -1 ! real end of file else0 1067 close (2) ! Error opening indirect file nunit=1" end if ! Which unit had EOF end if ! Hash range test end if ! type of record2 300 continue ! Error decoding y/m/d/t fields, end do ! Read next line from current file close (1) ! Close first-levele! 99 continue ! Failed first openy endww iy = iy + 1 + yspa ! move down one line else% ip = ip + 1 ! increment day number End If end do* if (ip .ne. 1) ! Partial buffer remains 1 then* call dtcat(ixo,iy) ! Position cursor/ write (iterm,1) (wknums(i), i = 1, ip - 1) ! Write rest of array end if 1 format('+',6(a2,x),a2) endwwgmbvFc Subroutine to extract and convert time-of-day string for DTC package=c Converts string of form hh:mm to integer between 80 and 173 Ac (half-hour intervals). If range h1:m1>h2:m2 is present, secondr(c value is returned, else same as t1>t1.c Special casestc * => {itr1}>{itr2}c E or EV => 17:00 c h: => 0h:00x,c h:n => 0h:n0 (if n .ge. 3, then 3, else 0)c h1>h2 => h1:00>h2:00Ec If ':' or '>' is not 2nd or 3rd character, or not '*', 'E' or 'EV',dBc entire string ish left untouched, and default values are returnedc (parameters unchanged)" subroutine dtctimcvt (itr1, itr2)) include 'Dtc_Source(comdtc_Common)/list'v byte ll, ln1, wk(2) integer*2 iwk logical first, expectmin# equivalence (line, ln1), (iwk, wk)e+ include 'Dtc_Source(stmtfunc_Common)/list'n it1 = itr1 ! Caller's limitse, it2 = itr2 ! (formerly 8:00 AM > 5:30 PM) ix = 0 ! Amount to strip4 if (ln1 .eq. '*') then ! Check special cases first% ix = 1 ! Deifaults, dump 1 char!+ else if ((ln1 .and. ucmask) .eq. 'E') then  it1 = 170 ! Set eventidei it2 = it1 ix = 1 0 if ((line(2) .and. ucmask) .eq. 'V') ix = 2 elsen i = 0 ! Temp index  first = .true. ! Helpful$ 10 if (numeric(line(i+1))) then if (numeric(line(i+2))) then wk(1) = line(i+1) wk(2) = line(i+2) ih = icvtbin(iwk) * 10 i = i + 2 else" ih = icvtbn1(line(i+1)) * 10 i = i + 1 end ifj if (line(i+1) .eq. ':') then i = i + 1t" if (numeric(line(i+1))) then im = icvtbn1(line(i+1)) if (im .ge. 3) then im = 3n elser im = 0 end ifc ih = ih + imr i = i + 15 if (numeric(line(i+1))) i = i + 1 ! Just ignore it end if+ ix = i ! Accept all processed charsN end if6 if (ih .lt. 70) ih = ih + 120 ! Force early AM to PM8 ih = min0(max0(ih, 80), 180) ! Normalize within limits if (line(i+1) .eq. '>') then k i = i + 1i' ix = i ! Insure it gets copied  it2 = ih if (first) then it1 = it2 first = .false. go to 10 end if. else if (ix .ne. 0) then ! Got some numeric if (first) thenb! it1 = ih ! terminated by ':'1 it2 = ih ! first time t1>t1 else it2 = ih ! 2nd numeric'( ix = i ! Claim everything looked at end if ! Which time ! end if ! Range delimiter ('>')e end if ! First numeric2 end if ! All others unrec ognized (includes EOL) itr1 = it1 ! All exit here+ itr2 = max0(it2, it1) ! Make sure range OKVD if (ix .ne. 0) call shrink (ix, ifnb, lnb) ! Unload what we've used endww=1,9 ! Byte-at-a-time Monthn(i) = months(i,imm) end do c All done. endwwmvIc------------------------------------------------------------------------lcfc Desk Top Calender Programc c Mitch Wyle 17.11.82 Program DtcvaxFcccr>c This program provides an on-line appointment calender system?c for daily appointments, week-at-a-glance schedule, and month-?c at-a-glance schedule. A facility is provided for a daily re-1 c minder.oco@c The program has help and menu prompting facilities for the newCc user and the ability to interprent an MCR line for the experiencedi@c user. The CRT screen functions are specific to the DEC VT-100*c screen terminal, as is the FORTRAN code.coIc------------------------------------------------------------------------ c c Compile:c Ic------------------------------------------------------------------------!c Declarations:cE include '($ssdef)/nolist' ! Define ss$_normal (and a whole lot more)n; include 'Dtc_Source(comdtc_Common)/list' ! Get common filenL include 'Dtc_Source(escdtoc_Common)/list' ! Frequently-used escape sequences include '($smgdef)'t"c Initialize common declared above% byte ln1 ! first character of line8/ integer*2 ln2 ! first two characters of line character*84 comlin /' '/0 character*25 fnamech /'SYS$LOGIN:APPOINTS.DAT'// data fname(23) /0/, ! Make FORTRAN OPEN happy + 1 fnsz /8/, ! Length of default value? 2 comlen /0/, comidx /0/ ! Length, location in command linei& equivalence (comlin, line, ln1, ln2), 1 (fname, fpnamech) & data homescrn /'[H'/, clrscrn /'[J'/,/ 1 dhdw1 /'#3'/, dhdw2 /'#4'/, dwide /'#6'/,; 2 resetvattr /'[m'/, revattr /'[7m'/,hilight /'[1;4m'/,e 3 lolight /'[0m'/ % data incmod /1/ ! Default to daymc End common initialization ;C INCMOD will flag day/week/month/year default increment...c 1=day, 2=week, 3=month,4=yearl> byte incsel(4) /'D', 'W', 'M', 'Y'/ ! Auto display after +/-; integer*4 lib$get_foreign ! Get DCL command line, unparsed < logical exflag/q.false./ ! True if data on DCL command lineL include 'Dtc_Source(stmtfunc_Common)/list' ! Get useful statement functions c Begin code:l. istatus = smg$create_virtual_keyboard(ikeyid)$c first set up default data filename? CALL ASSIGN(iterm, 'TT:') ! >>> Assumes VT100, interactive <<< c Escape sequences used:cn*c 7 Save cursor and video attributesc 8 Restore ...rc < Exit ATS modei:c > Keypad numeric mode (Exit Alternate Keypad mode)$c [?4l Reset scrroll mode (jump)(c [?6l Reset origin mode (absolute)2c [r Set top/bottom margins (default - 1:24)0c [m Graphic rendition = primary (default)3c [H Set cursor at home position (upper left) c (B G0 (SI/^O) = US ASCII(c )0 G1 (SO/^N) = Special graphics%c ^O Shift In (Select G0 (US ASCII))'& write (iterm,100) ! Clean up terminal 1 esc,'<', esc,'>',$ 2 esc,'[?4l', esc,resetvattr, ! [m 3 esc,'(B', esc,')0',- 4 esc,'7', esc,'[?6l', esc,'[r', esc,'8', si,s. 100 format ('+', 21a, $) ! Escape sequences4 call dtcidate(idmo,iddy,ibigyr) ! Get current date:c First time, get the MCR line, then parse and process it:0c INIT exflag=.false. ! Assume terminal input& istat=lib$get_foreign(comlin,,comlen)2 if ((istat .ne. ss$_normal) .or. (comlen .eq. 0)) 1 go to 77 Kc Allow for single operation to insert an appointment in upper & lower case0 if (ln1 .eq. '"') then ! User quoted the line4 do i = 2, comlen ! First of many re-ctopy opns% line(i-1) = line(i) ! copy it down- end doe comlen = comlen - 1 end ifd= line(min0(comlen+1, icmln)) = "0 ! Set end of line character 3 exflag=.true. ! Flag for exit after one command*2c Generalized parser and scanner routine for line:+ 1 continue ! Loop up here on any input.2Gc initialize flags to normal search display sense (show occupied times)a"c and no special meeting setups... rdspfg=0  ctlfg=01 1111 continue ! Re-enter here, after "+"u, etce&c write(iterm,7787) (line(iv),iv=1,64)C 7787 format(' lin1:',64a1)' comidx = 1 ! Initialize for parsing  if (lcalpha(ln1))1 1 ln1 = ln1 .and. '5f'x ! Change to upper case  If ((ln1 .eq. 'D')e 1 .or. (ln1 .eq. '=') 2 .or. (ln1 .eq. '*'))h 3 thenh incmod=1 ( call day ! (line) ! display daily, go to 6 else if (ln1 .eq. 'W')r 1 thenn incmod=2s" call week ! (line) ! weekly, go to 6 else if (ln1 .eq. 'M')- 1 then ivncmod=3 1 call month ! (line) ! or monthly schedules,> istatus = smg$read_string(ikeyid,comlin,' ',,,,,comlen,itchr) go to 6 else if (ln1 .eq. 'Y') 1 then incmod=40 call year ! (line) ! or full-year calendar go to 69c flag multiple schedule of meeting to enable multi entry else if (ln1 .eq. 'S') 1 then ln1='D' ctlfg=1 incmod=1 call day ! (line) go to 6Ac use G as a schedule that will write appointments in current andwc all indirected files.r else if (ln1 .eq. 'G')v 1 theno ln1='D' ctlfg=2 incmod=1r call day ! (line) go to 6- else if ((ln1 .eq. '+') .or. (ln1 .eq. '-')): 1 theni# Call dtcdatinc ! (line,Incmod)e= if (ln1 .ne. 0) go to 450 ! something left, schedule it}( ln1 = incsel(incmod) ! Phony line$ line(2) = "0 ! End-of-line ? comlen = 10* go to 1111 ! Display based on incrCc reverse display flag so we hunt up free slots... nxote week, month,*c routines all get hacked on to do this...Bc reparse line after copying it down 1 character to remove the 'N' else if (ln1 .eq. 'N')  1 thenw rdspfg=12 call shrink(1, ifnb, lnb) go to 1111( else if (ln1 .eq. 'P')i! 1 then ! Purge old appointments1 call strip ! (line) go to 6C else if (ln1 .eq. 'T')"C 1 then ! Purge old appointments'C call DTC_PRINT (LINE(2)) ! (line)s C go to 6r- else if ((ln1 .eq. 'U') .or. (ln1 .eq. 'X'))ey 1 thenl/ call strip ! (line) ! Cancel or reschedule0: if (ln1 .gt. ' ') go to 1 ! Re-scan if leftover chars go to 6 else if (ln1 .eq. 'L') 1 then8c for locating free time, use week function and scan map ctlfg=1 ln1='W' incmod=2 call week ! (line)) go to 6 else if (ln1 .eq. 'T')k 1 thene ln1='D' incmod=1k9 call day ! (line) ! today's memos then exit+ go to 999 else if (ln1 .eq. 'R')f 1 then1 ln1='zW' incmod=2 1 call week ! (line) ! remind one of this weekc go to 999 else if (ln1 .eq. 'C') # 1 then ! calendar print for month incmod=3  call month ! (line) go to 999 else if (ln1 .eq. 'I')J 1 then ! Reset default date 3 call dtcicomd ! Process possible date string$ go to 6 ! (for testing mods)C else if ((ln1 .eq. 'H') .or. (ln1 .eq. '?') .or. (itchr .eq. 257))i 1 then ) call dhelp ! HELP! (instructions) go to 68{c f filename enters new default data file name to use... else if (ln1 .eq. 'F') 1 then= call shrink(1,ifnb, lnb)n if (ifnb .eq. 0). 1 theno fnamech = 'DTC_FILE'% fnsz = 8 ! Length of default valuet else do i=1,lnb fname(i)=line(i) end do fnsz=lnb end if/ fname(fnsz+1)=0 ! Make FORTRAN OPEN happyn go to 6 else if ((ln1 .eq. 'Q') .or. ' 1 ((ln2 .and. '5f5f'x) .eq. 'EX') .or.d 2 (itchr .eq. 26)) 3 then  go to 999 ! |Exeunt omnes else c3c Now get a bit fancy: (play with the line string)icn if (ln1 .eq. 'E') go to 450c * If (.not. numeric(ln1)) go to 5 ! unknownc3 450 continue ! From E above, or leftovers for +/-c'c The first character is a number or E,(c call the daily appointment subroutine: incmod=1 line(icmln) = "0 ! Tag e/o/l call day ! (line) go to 6 End Ifc- 5 continue ! First character not recognized,c Line was uninterpretable, so display menu:; 77 call menu ! Also display menu first time if no command0 6 continue ! get a new line and hop back up... if (exflag) go to 999cI7c DEBUG: Display remains of line after operations on itc c !!! iln = 1Mc !!! do i = 1, icmlnIEc !!! if (line(i) .eq. 0) line(i) = "32 ! control Z, displays as BLOT #c !!! if (line(i) .gt. ' ') iln = i c !!! end do*c !!! WRITE(iterm,93) (line(i), i= 1, iln)*c !!! 93 format(' ', a1, ': DTC: ',$)C C write(iterm,93)C 93 format(' DTC: ',$)TCO~swc-$c Daily Print Appointment subroutinec-c- c Input: -Hc Command - 84 characters; Format: PR [mmddyy>MMDDYY [Outdevice]]c7 c Output:o:c appointments are output on the specified output manner.:C If no output is specified, it is directed to SYS$PRINT."C Allowed output keywords includeCg(C LQ DTC$PRINT_LQ (SYS$PRINT)%C PRint DTC$PRINT (SYS$PRINT)rc SCratch SCRATCH.FIL C TErminal Current terminalC TT: Current terminalCM:C Only the first two letters of any keyword are required.:C If DTC$PRINT does not exist, the output is directed to C SYS$PRINT.dCC James G. Downward-C KMS Fusion, Inc-C P.O. Box 1567-C Ann Arbor, Mich. 48196C (313)-769-8500 C 15-Jul-1984-Hc-----------------------------------------------------------------------c OPTIONS/NOI4e SUBROUTINE DTC_PRINT(Command)chc Declarations:cc CHARACTER*1 Cesc,Cnull,Cbell CHARACTER*4 Cbold, Cnorm CHARACTER*6 Cfile_Date !/ CHARACTER*9 Cdate1 ! First date (if present)t+ CHARACTER*9 Cdate2 ! 2nd date if present  CHARACTER*10 Cbuf ! CHARACTER*20 Cout_Filet CHARACTER*60 Cinrec !+ CHARACTER*60 Coutput ! to direct output c CHARACTER*84 Command !/ CHARACTER*80 Cline  BYTE FNAME(60)* BYTE Ldate1(9),Ldate2(9) ! The two dates2 LOGICAL*1 Lterm ! If output to terminal is true0 LOGICAL*1 Ldelete ! If file deleted on output INTEGER*2 FNSZ INTEGER*2 ID ! Julian Day INTEGER*2 IM  ! Julian Month INTEGER*2 IYE ! Julian Year? INTEGER*2 RDSPFG ! flag to rev sense of dsply of timeh5 INTEGER*2 CTLFG ! misc control flags herem INTEGER*2 IDYR,IDMO,IDDY  INTEGER*4 Ilength ! COMMON/DEFDAT/ IDYR,IDMO,IDDY% common/ctls/ rdspfg,ctlfg,Check_Type1 COMMON /Constants/ Cesc,Cbell,Cnull,Cbold,Cnorm ( COMMON/FN/ FNSZ,FNAME ! Pass file namec c Initialize:bct% IM=IDMO ! Set current dflt month ID=IDDY ! day IYE=IDYR ! and yearo) Cdate1= ' ' ! be sure we always startl( Cdate2= ' ' ! off with a clean slate Coutput = ' ' !t READ(Cdate1,'(9A1)')Ldate1 ! READ(Cdate1,'(9A1)')Ldate2 !ctc Parse that line!ScN(C Erase any error messages on line 24Cv? WRITE(*,9998)Cnull//Cesc//'[24;1H'//Cesc//'[K'//Cesc//'[23;1H' 2 Cline=Command(1:80) ! Grab/shorten command line9 CALL DTC_Clean_Up_Line(Cline) ! remove mult spaces, etc $ CALL String_Length(Cline,Ilength) !4 Ispc=INDEX(Cline(1:Ilength),' ') ! Find first space7 IF(Ispc .EQ.0) THEN ! If for some reason no command[. Ilength=0 ! on line here (there should, GOTO 5 ! but who cares), use default END IF ! date and print4 Cline=Cline(Ispc+1:) ! Remove the 'Print' command4 CALL String_Length(Cline,Ilength) ! Find new length75 IF(Ilength.EQ.0) THEN ! No command on line so set ineA WRITE(Cdate1,10) Idyr,Idmo,Iddy ! the default date for both'10 FORMAT(I2.2,I2.2,I2.2) != WRITE(Cdate2,10) Idyr,Idmo,iddy ! both hi and low datesm Coutput=' ' ! ! GOTO 100 ! Go print datesh END IFe" Isplt=INDEX(Cline(1:Ilength),'>')? IF(Isplt.EQ.Ilength) GOTO 8050 ! Date missing, warn usern6 IF(Isplt.GT.0) THEN ! If '>' present then two dates. Cdate1=Cline(1:Isplt-1) ! Got first dateA IF(Cdate1(1:1).LT.'0' .OR. ! If date does not start with N - Cdate1(1:1).GT.'9') GOTO 8070! Warn if invalid date formatF IF(Cline(Isplt+1:Isplt+1).NE. ' ') THEN! If no s pace after the '>'6 Cline=Cline(Isplt+1:) ! use 2nd half of line; Ilength=Ilength-Isplt+1 ! xfer the correct lengthu+ ELSE ! Else If spc follows the '>' 6 Cline=Cline(Isplt+2:) ! We striped mult spaces9 Ilength=Ilength-Isplt ! so this is safe operationa) END IF ! Now have first date if anyu= IF(Ilength.EQ.0) GOTO 8050 ! Date missing, warn user9 Ispc=INDEX(Cline(1:Ilength),' ') ! Find next seperator= IF(Ispc.EQ.0) Ispc=Ilength+1 ! I f missing, use dnd of lne11 Cdate2=Cline(1:Ispc-1) ! Now have second dateA IF(Cdate2(1:1).LT.'0' .OR. ! or do we?, Check to see if r< - Cdate2(1:1).GT.'9') GOTO 8070! its legal; IF(Ispc.LT.Ilength) THEN ! also may have output stringa Coutput = Cline(Ispc+1:) ! END IF) ELSE ! Else just one date and outputc: Ispc=INDEX(Cline(1:Ilength),' ') ! Find space seperator= IF(Ispc.EQ.0) Ispc=Ilength+1 ! If missing, use end of lneo; IF(Ispc-1.GT.LEN( Cdate1)) THEN ! If date string too long 5 Coutput=Cline(1:Ispc-1) ! must be output data ( ELSE ! Else assume is date string9 Cdate1=Cline(1:Ispc-1) ! Just one date, the first = IF(Ispc.LT.Ilength) THEN ! and if stuff still on the A Coutput = Cline(Ispc+1:) ! line, use it as output param END IF !A IF(Cdate1(1:1).LT.'0' .OR. ! If date does not start withdG - Cdate1(1:1).GT.'9') THEN ! a number, it is not a dateB Coutput=Cdate1(1:Ispc-1) ! so make it the output parm> WRITE(Cdate1,10) Idyr,Idmo,Iddy ! & set dflt date> WRITE(Cdate2,10) Idyr,Idmo,Iddy ! & set dflt date- GOTO 100 ! and go off to print  END IF ! End if) END IF ! End if2 Cdate2=Cdate1 ! Set default date if only one END IF ! End if< CALL String_Length(Cdate1,Ilen1) ! Now convert date strings9 Call String_Length(Cdate2,Ilen2) ! to valid logicals forcK READ(Cdate1(1:Ilen1),'(A1)')(Ldate1(I),I=1,Ilen1) ! cnvt to generaleB READ(Cdate2(1:Ilen2),'(A1)')(Ldate2(I),I=1,Ilen2) ! string CALL Cnvt_To_MMDDYY(Ldate1,Ier)1 IF(Ier.NE.0) GOTO 8090 ! Bad date formatsl CALL Cnvt_to_MMDDYY(Ldate2,Ier)0 IF(Ier.NE.0) GOTO 8090 ! Bad date format, WRITE(Cdate1(1:6),'(6a1)')(Ldate1(I),I=1,6), WRITE(Cdate2(1:6),'(6a1)')(Ldate2(I),I=1,6)> Cdate1=Cdate1(5:6)//Cdate1(1:4) ! Transpose to YYMMDD format# Cdate2=Cdate2(5:6)//Cdate2(1:4) !1 100 Continue#c write(*,50) Cdate1,Cdate2,Coutputf4c50 format(' *',A,'*',/,' *',A,'*',/,' *',A,'*',/,/)>C Now we have starting and stopping dates, lets open the file C and print out any dates therecg Open (unit =1,  - file =FNAME,l - status ='OLD',c - form ='FORMATTED', - READONLY, - ERR=8020)- Lterm=.FALSE. ! Assume writing to fileo Cout_file='LP.LIS' ! ; IF(Coutput(1:2) .EQ. ' ') THEN ! If null, dflt to PRINTe CONTINUE !: ELSE IF(Coutput(1:2) .EQ. 'TT') THEN ! Do not open file  Lterm=.TRUE. !( ELSE IF(Coutput(1:2) .EQ. 'TE') THEN ! Lterm=.TRUE. !9 ELSE IF(Coutput(1:2) .EQ. 'SC') THEN ! Use scratch fileo. Cout_File='SCRATCH.FIL' ! with this name' Ldelete=.FALSE. ! do not delete q= ELSE IF(Coutput(1:2) .EQ. 'PR') THEN ! Output to SYS$PRINT CONTINUE ! = ELSE IF(Coutput(1:2) .EQ. 'LQ') THEN ! Use letter Qual pntr( CONTINUE !t ELSE ! GOTO 8110 ! If bad choice END IF00 IF (.NOT. Lterm) THEN ! if output not to term OPEN(Unit =2, - File =Cout_File, - Status ='Unknown',% - Carriagecontrol='LIST',f - ERR =8150)R4 WRITE(2,200) Cdate1(3:4),Cdate1(5:6),Cdate1(1:2),: - Cdate2(3:4),Cdate2(5:6),Cdate2(1:2).200 FORMAT(' ',T30,'DTC Appointment List',/,B - ' ',T30,A,'/',A,'/',A,'/',' - ',A,'/',A,'/',A,/,/)" ELSE ! Else if to a terminal CALL PAGE4 WRITE(*,200) Cdate1(3:4),Cdate1(5:6),Cdate1(1:2),; - Cdate2(3:4),Cdate2(5:6),Cdate2(1:2)  END IF 11000 read(1,1200,end=1400) ihy,ihm,ihd,iht,Cinreco1200 format(3i2,i3,A)l' WRITE(Cfile_Date,'(3I2.2)')Ihy,Ihm,Ihd c WRITE(Cbuf(1:3),'(I3.3)')Iht5c WRITE(*,1201)Ihd,ihm,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec =c1201 FORMAT(' *'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,A)A1c WRITE(*,1202)CFILE_DATE,CDate1(1:6),Cdate2(1:6)nc1202 format(' **',a,3x,a,3x,a)a= IF(Cfile_Date.LT.Cdate1(1:6) .OR. ! Only print if in rangeo7 - Cfile_date.GT.Cdate2(1:6)) GOTO 1000!  WRITE(Cbuf(1:3),'(I3.3)')Ihte CALL String_Length(Cinrec,J)t* IF(Lterm) THEN ! If output to terminal; WRITE(*,1210)Ihm,ihd,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec(1:J)(<1210 FORMAT(' 'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,A) ELSEt= WRITE(2,1210)Ihm,ihd,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec(1:J)  END IFi goto 100021400 continue ! no more appointments left in file.- IF(Lt erm) WRITE(*,1410)Cesc,Cbold,Cnorm,CescaC1410 FORMAT(' ',/,' ',A,'[24;1HPress ',A,'RETURN',A,' to continue',n - A,'[23;1H') CLOSE(1)e0 IF(.NOT. Lterm) THEN ! If output not to term# IF(Coutput(1:2) .EQ. 'SC') THEN+" CLOSE(Unit=2,DISPOSE='KEEP')+ ELSE IF(Coutput(1:2) .EQ. 'PR' .OR. !,1 - Coutput(1:2) .EQ. ' ') THEN !> CLOSE(Unit=2,DISPOSE='PRINT/DELETE') ! PRINT/DELETE file? ELSE IF(Coutput(1:2) .EQ. 'LQ') THEN ! If LQ, ask system to% @PBwCc subroutine FNSCAN - scan file-name record (999999999x=) (c and strip space, mark 0 at end of name, subroutine fnscan(work, maxlen, iwkln, ijr) byte work(maxlen) byte ll% ij = 0 ! Initialize output indexs+ do ii=1, min0(iwkln, maxlen) ! Start loopl* ll = work(ii) ! Get input character5 if (ll .gt. ' ') then ! Strip all spaces & ctlsN+ if (ll .eq. '=') go to 10 ! '=' marks end$ ij = ij + 1 ! Character accepted work(ij) = ll ! Copy it$ end if ! (graphic character) end do ! Loop6 10 work(min0(ij+1,maxlen)) = 0 ! Set marker for OPEN& ijr = ij ! Return length of string endwwion, IncC P.O. Box 1567C Ann Arbor, Mich. 48196C (313)-769-8500 C 15-Jul-1984Hc-----------------------------------------------------------------------c OPTIONS/NOI4 SUBROUTINE DTC_PRINT(Command)cc Declarations:c CHARACTER*1 Cesc,Cnull,Cbell CHARACTER*4 Cbold, Cnorm CHARACTER*6 Cfile_Dat;nwHc-----------------------------------------------------------------------csc Subroutine Gaby cu"c Part of Mitch Wyle's DTC programcA3c return a string corresponding to the month numberc<c Month number contained in im. Send back string in monthn.c (JANUARY for 1, etc.)TcLHc-----------------------------------------------------------------------clDc modified 850315 - Center month names in table, use mixed case - CG SUBROUTINE gaby(im,monthn)ncc Declarations: ci Byte monthn(9)RCc *** character*9 monthn ! Can't use, char params expect descriptorecsIc Table of month names and numbers (centered, even lengths biased right):Gc2 Byte months(9,14)( character*9 monthch(14)/ ' December',6 1 ' January ', ' February', ' March ', ' April ',6 2 ' May ', ' June ', ' July ', ' August ',6 3 'September', ' October ', ' November', ' December', 4 ' January '/! equivalence (months, monthch)c 1c Select the right month and fill monthn with it: ceC ALLOW FOR OVERFLOWS... IMM=IM+1 1c *** monthn = monthch(imm) ! String assignmentAcd Do 1 i=1,9 ! Byte-at-a-timet Monthn(i) = months(i,imm) 1 Continuee c All done.a returnr endwwn line 24C? WRITE(*,9998)Cnull//Cesc//'[24;1H'//Cesc//'[K'//Cesc//'[23;1H'2 Cline=Command(1:80) ! Grab/shorten command line9 CALL DTC_Clean_Up_Line(Cline) ! remove mult spaces, etc$ CALL String_Length(Cline,Ilength) !4 Ispc=INDEX(Cline(1:Ilength),' ') wHc-----------------------------------------------------------------------c c Menu subroutinerch"c part of Mitch Wyle's DTC programcu c Inputs: c None c c Output:pc display screen (see below) coHc-----------------------------------------------------------------------c SUBROUTINE menuc!c Declarations:nco6 include 'Dtc_Source(comdtc_Common)/list' ! Need ITERM) include 'Dtc_Source(escdtc_Common)/list'2c c byte esc /"033/,c integer iterm/6/co c Initialize:ac*c iterm = 6 ! Output terminal unit number c esc = "033c call dtcat(1,1)I8 write(iterm,1) esc,homescrn, esc,clrscrn ! clear screen 1 format('+',4a, $)ca0 write(iterm,2) '+', esc,dhdw1 ! double-height0 2 format(3a,13X,'D T C C o m m a n d s') ! ../ write(iterm,2) ' ', esc,dhdw2 ! double-width cf write(iterm,3)a 3 format(D 1 8x,'D [mmddyy] - Appointment Schedule for dd mm yy',/,F 2 8x,'W [mmddyy] - Week-At-A-Glance for week o f dd mm yy',@ 3 /,8x,'M [mmyy] - Month-At-A-Glance for mm yy',/,< 4 8x,'Y [yy] - Full Year calendar for yy',/,G 5 8x,'+ or - nnZ - Add/Subt nn Z (Z=D,W,M,Y): change date', 5 /,D 6 8x,'N(cmd str) - Reverse display sense of M or W cmd',! 6 ' (show free time)',/,aH 7 8x,'L [mm]dd[yy] n - Locate time (n * 30 mins.) free for mtg', 7 /,G 8 8x,'hh:mm>hh:mm - Add or change appointments for hh:mm',/,=D 9 8x,'EV (pseudo time) - Add or change EVening appointment',/,H 1 8x,'P [mmddyy] - Purge appointments prior to mmddyy',/,8x,HCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxH 2 'U [mmddyy] t1[>t2] - Unschedule (cancel) appointments',/,H 3 8x,'X d1 t1 d2 t2 - eXchange (reschedule) appointments',/,4 3 8x,' (then execute if present)', /,G 4 8x,'S [mmddyy] - Schedule multiple activity on mmddyy',/, F 4 8x,' (Drops n otices in all indirected users files also)',/,D 5 8x,'G [mmddyy] - File activities in multiple files',/,G 6 8x,'F FILENAME - Change default data file to Filename',/,h? 7 8x,'I - Reset default date to today.',/,n( 8 8x,'H or ? or PF2- Help!',/,9 9 8x,'Q, EX, or ^Z - Exit', $) ! After all that(ct returnTc' endww If date does not start withG - Cdate1(1:1).GT.'9') THEN ! a number, it is not a dateB CoutpuwHc-----------------------------------------------------------------------c!"c Mischy month printing subroutinect"c part of Mitch Wyle's DTC programc c Inputs: c ib - begining day of the weekc il - length of month in days!c xoff - offset for x coordinateC2c xspa - number of spaces to skip between numbers!c yoff - offset for y coordinatet/c yspa - number of lines to skip between lines ci c Output:dc display screen (see below) cHc-----------------------------------------------------------------------c- SUBROUTINE mischy(ib,il,xoff,xspa,YOFF,yspa)Icec Declarations:Lcn' integer ib ! begining day of the week & integer il ! length of month in days integer xoff ! x offset1 integer xspa ! number of spaces between numbersW integer yoff ! y offsetd6 integer yspa ! number of lines to skip between linesc)6 include 'Dtc_Source(comdtc_Common)/list' ! Need ITERM) include 'Dtc_Source(escdtc_Common)/list')c/ integer ix ! x coordinate of where to put dayt/ integer iy ! y coordinate of where to put day,3 integer ip ! the day of the week for date in handd integer ixo ! xoff + 1ca$c integer iterm/6/ ! terminal unit #cO) integer nums(31) ! numbers as characters? 1 / ' 1', ' 2', ' 3', ' 4', ' 5', ' 6', ' 7', ' 8', ' 9', ? 2 '10', '11', '12', '13', '14', '15', '16', '17', '18', '19', ? 3 '20', '21', '22', '23', '24', '25', '26', '27', '28', '29',o 4 '30', '31'/ c ; integer wknums (7) ! To contain copies of above, or blanksFcu c Initialize:'c)*c iterm = 6 ! Output terminal unit numberc!$ do 99, i = 1, 7 ! One week's worth" 99 wknums (i) = ' ' ! initializecC ip = ib$ ix = xspa + 1 ! Used in format # 1 ixo = xoff + 1C iy = 4 + YOFFC *** If (yspa .ne. 0) iy = 12c 3c Now write month out to screen, one day at a time:)cH Do 5 i=1,il0 wknums(ip) = nums(i) ! Get day as character2 If ( ip .eq. 7 ) then ! is it Saturday again?/ call dtcat(ixo,iy) ! Position cursor for linea- write (iterm,1) wknums ! Write filled array!! ip = 1 ! reset day to Sunday.t) iy = iy + 1 + yspa ! move down one line- elset% ip = ip + 1 ! increment day numbero End Ifc #c ix = (3+xspa) * ip - 2 + xoff2*c call dtcat(ix,iy) ! position cursor4c write(iterm,1) i ! write day number to screenc 1 format('+',i2, $)Tcp 5 Continuetc,. if (ip .ne. 1) then ! Partial buffer remains do i = ip, 7 ! Pad it $ wknums(i) = ' ' ! with blanks end do*c0* call dtcat(ixo,iy) ! Position cursor0 write (iterm,1) wknums ! Write filled array end ifEcI 1 format('+',6(a2,x),a2)) returni endwwec1200 format(3i2,i3,A)' WRITE(Cfile_Date,'(3I2.2)')Ihy,Ihm,Ihdc WRITE(Cbuf(1:3),'(I3.3)')Iht5c WRITE(*,1201)Ihd,ihm,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec=c1201 FORMAT(' *'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,A)1c WRITE(*,1202)CFILE_DATE,CDate1(1:6),Cdate2(1:6)c1202 format(' **',a,3x,a,3x,a)= IF(`2SxHc-----------------------------------------------------------------------c)c Month-at-a-glance subroutinec:"c part of Mitch Wyle's DTC programci c Input: I3c line - 72 byte string; Format: M [dd[19[yy]]]1c) c Output:,c display screen (see below)c2c LineAc 1 Prevmonth NextmonthAc 2 SMTWTFS SMTWTFSC 3-8 Calendar Calendar$c 9/10 Y e a r M o n t h Y e a rc 11 S M T W T F Sc 13-23 C a l e n d a rncl+c Lines 9/10 are double-height/double-widthC"c Odd lines 11-23 are double-widthc Even lines 10-22 are blankcuHc-----------------------------------------------------------------------cu&c Modified 850318, several changes- CG6c Display today's date in current, prev or next monthc in reverse videoQ/c Write out >>> only <<< non-blank flags (*'s) 9c Speed-up of month display (actually in dtcdspmth subr)E(c Months mixed-case and centered (GABY)=c Modified 850809 - display IBIGYR both sides of month, DH/DWt SUBROUTINE month ! (line)c Declarations:/) include 'Dtc_Source(comdtc_Common)/list' * include 'Dtc_Source(apptdtc_Common)/list') include 'Dtc_Source(escdtc_Common)/list'42 byte temp(4) ! temporary string converting array integer id ! Julian Day9 integer im ! Julian Monthe integer iy ! Julian Year integer prveof, eofflgC% byte monthn(9), ! string month name 1 lmonth(9)@ logical*1 lmneven(12)/ ! Entries true if length of name is even6 1 .false., .true., .false., .false., .false., .true.,6 2 .true., .true., .false., .false., .true., .true./= logical*1 lmnodd(12) ! Entries true if length of name is oddC6 1 /.true., .false., .true., .true., .true., .false.,6 2 .false., .false., .true., .true., .false., .false./. Byte out(79) ! The output string and * array2 byte rchr ! Flag set (or reset) character byte ln1 ! Same as line(1) equivalence (line, ln1)+ include 'Dtc_Source(stmtfunc_Common)/list' #c Trim off the M from command line: ! if ((ln1 .and. ucmask) .eq. 'M')[ 1 call shrink(1, ifnb, lnb)' call dtcdatcvt(2) ! Decode date string(' im=idmo ! Pick up result from common id=iddy iy=ibigyrH call dtcidate(irm,ird,iry) ! Real month,day,year, for display highlight3c Move the cursor to the top part, clear the screenp+ write(iterm,600) esc,homescrn, esc,clrscrn' 600 format ('+', 4a, $)-c Now start building the output string: (out)c encode(4, 20, temp, err=11) iy 11 continue 20 fo!rmat(i4),c Calculate nominal prev, next month numbers lm = im - 1 ly = iy nm = im + 1 ny = iy If ( im .eq. 1 ) then lm = 12 ly = iy - 1 k else If ( im .eq. 12 ) then nm = 1 ny = iy + 1 End IfuC PRINT PREVIOUS MONTH call dtcmthnam(lm,lmonth)"C PRINT NEXT MONTH CALENDAR AT TOP call dtcmthnam(nm,monthn)/C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS= ix = 31 if (lmneven(lm)) ix = ix + 1  call dtcat(ix, 1) write(iterm,6) lmonth ix = 61 if (lmneven(nm)) ix = ix + 1r call dtcat(ix, 1) write(iterm,6) monthn 6 format ('+', 9(a1, x), $) call dtcat(1, 2)= write(iterm,7)eB 7 format('+','Su Mo Tu We Th Fr Sa',T60,'Su Mo Tu We Th Fr Sa',$)7c *** call dtcat(35, 7) ! Center year above cur monthc *** write(iterm,96) tempc *** 96 format ('+', 4(x, a1))@c Now display last month, header for this month, and next month:+c Last month to upper-left corner of screen call dtcalcdow(ib,il,lm,ly) call dtcdspmth(ib,il,0,0,-1,0)A If ((irm .eq. lm) .and. (iry .eq. ly)) then ! today in rev video-9 irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0)s7 irwk = (ird + ib - 2)/7 ! Week in month (orig 0)m( call dtcat ((irdw*3) + 1, irwk + 3)7 write (iterm,684) esc,revattr, ird, esc,resetvattr end if-,c Next month to upper-right corner of screen call dtcalcdow(ib,il,nm,ny) call dtcdspmth(ib,il,58,0,-1,0)A If ((irm .eq. nm) .and. (iry .eq. ny)) then ! today in rev video9 irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0)o6 irwk = (ird +ib - 2)/7 ! Week in month (orig 0)) call dtcat ((irdw*3) + 59, irwk + 3)d7 write (iterm,684) esc,revattr, ird, esc,resetvattr end ifr0c display big banner header name of this month:c call dtcat(ix,9) call dtcat(1,9) call dtcmthnam(im,monthn) ix = 11 if (lmneven(im)) ix = ix + 1o ixx = ix - 9e ixy = 14 - ix2 write(iterm,8) '+', esc,dhdw1, temp, monthn, temp= 8 format(3a, 4(a1, x), x, 9(x,a1), x, 4(x, a1), $) 2 write(iterm,8) ' ', esc,dhdw2, temp, monthn, tempMc Now print the week day headers for this month, and the days for this month:n call dtcat(1,11)) write(iterm,10), esc,dwide 10 format('+', 2a,0 1 'Sun Mon Tues Weds Thurs Fri Sat', $)0c x x x x x x x x. write (iterm,138) ! Mark double-width lines 1 esc,'[13H', esc,dwide, 2 esc,'[15H', esc,dwide, 3 esc,'[17H', esc,dwide, 4 esc,'[19H', esc,dwide, 5 esc,'[21H', esc,dwide, 6 esc,'[23H', esc,dwide 138 format ('+', 24a, $)-c- call dtcalcdow(ib,il,im,iy)3c call dtcdspmth(ib,il,8,8,8,1) ! For single-width2 call dtcdspmth(ib,il,1,3,9,1) ! For double-widthceA If ((irm .eq. im) .and. (iry .eq. iy)) then ! today in rev video-c-9 irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0)r7 irwk = (ird + ib - 2)/7 ! Week in month (orig 0)) call dtcat ((irdw*6)+2, (irwk*2)+13)e if (id .eq. ird) then4 write (iterm,684) esc,'[4;7m', ird, esc,resetvattr else 4 write (iterm,684) esc,revattr, ird, esc,resetvattr) go to 685 ! And show looking-at datee end if( 684 format('+', 2a, i2, 2a, $) else1< 685 irdw = mod (id + ib - 2, 7) ! Day of week (orig 0)6 irwk = (id + ib - 2)/7 ! Week in month (orig 0)) call dtcat ((irdw*6)+2, (irwk*2)+13)x4 write (iterm,684) esc,'[4m', id, esc,resetvattr end if2 if (rdspfg .eq. 0) then rchr='*' out(1) = ' ' else, rchr=' ' out(1) = '*' end ifn0 Do i= 2, 31 ! set the out array to all blanks: out(i) = out(1) end do 9c Now for files I/O to put *'s on days with appointments:,2 irqhash(1) = ihymd(iy, im, 1) ! Want entries for0 irqhash(2) = ihymd(iy, im, 31) ! current month eofflg = -1 prveof = 0e do while (prveof .ge. 0)y call dtcrdappt(eofflg, 0)' if (eofflg .ge. 0) out(ihd) = rchr' prveof = eofflg end doa4c Have now accumulated all info about current month,#c go back and flag appropriate days, iy = 13 ip = ib - 1 - Do i=1,il) ip = ip + 1 ! increment day numberx0 If ( ip .gt. 7 ) then ! is it Sunday again?! ip = 1 ! reset day to Sunday.1$ iy = iy + 2 ! move down one line End IfB if (out(i) .ne. ' ') then ! Write only non-blank entries !!!!c ix = 11 * ip - 3t ix = 6 * ip - 5f% call dtcat(ix,iy) ! position cursor - write(iterm,231) out(i) ! write * to screen 231 format('+',a1, $)n end if  end do  ! # days in month 1 999 call dtcat(1,23) ! Position for next promptu endww,/,G 6 8x,'F FILENAME - Change default data file to Filename',/,? 7 8x,'I - Reset default date to today.',/,( 8 8x,'H or ? or PF2- Help!',/,9 9 8x,'Q, EX, or ^Z - Exit', $) ! After all thatc returnc endww MONTH$x PHIL SHRINK@}x PHIL STRIP?e y PHIL TIMINCnwy PHIL WEEK ގy PHIL YEARS{ PHIL DAY8xFc Subroutine to shift LINE to left after current item has been scannedAc deletes blanks between that point and first non-blank charactern9c Performs no operation if current item is EOL (binary 0)Gc Sets return arguments pointing to first and last non-blank charactersr' subroutine shrink (iskip, ifnbr, lnbr)pc!) include 'Dtc_Source(comdtc_Common)/list' byte ll ifnb = 0s lnb = 01 if (line(1) .eq. 0) go to 999 ! Exit immediately ! ix = iskip + 1 ! start looking3 do while ((ix .le. icmln) .and. (line(ix) .ne. 0))t2 if (line(ix) .gt. ' ') go to 10 ! Found something ix = ix + 1 end do" line(1) = 0 ! Flag end, no copy go to 999 10 ifnb = 1 lnb = 1 Do i = 1, icmln-ix  ll = line(ix) line(i) = ll + if (ll .eq. 0) go to 999 ! Stop at EOL' if (ll .gt. ' ') lnb = i ix = ix + 1 end do'5 line(min0(lnb+1, icmln)) = 0 ! Flag EOL if not found' 999 ifnbr = ifnb ! Set return values lnbr = lnbb endww Initialize:c*c iterm = 6 ! Output terminal unit numberc$ do 99, i = 1, 7 ! One week's worth" 99 wknums (i) = ' ' ! initializec ip = ib$ ix = xspa + 1 ! Used in format # 1 ixo = xoff + 1 iy = 4 + YOFFC *** If (yspa .ne. 0) iy = 12c3c Now write month out to screen, one day at a time:c Do 5 i=1,il0 wknums(ip) = nums(i) ! Get day as character2 If ( ip .eq. 7 ) then ! is it Saturday again?/ call dtcat(ixo,iy) ! Position cursor for line- wr`xHc-----------------------------------------------------------------------c 8c Strip Daily Appointment subroutine (DTC Purge command)ce.c part of GLENN EVERHART'S MODS TO DTC programcs)c Input: command line - 72 bytes, format:yc! c P [mmddyy]r c orc U [mmddyy] [hh:mm[>hh:mm]]r c or6c X [mmddyy] [hh:mm[>hh:mm]] [mmddyy] [hh:mm[>hh:mm]]cn c Output: 8c Reads dtc.dat, and builds new dtc.dat, in the process6c strips old appointments (before date) from file (P),6c deletes appointments at specified time and date (U),>c or re-schedules (eXchanges) appointments from d1*t1 to d2*t2c2Hc-----------------------------------------------------------------------c SUBROUTINE strip ! (line)cc Declarations:c) include 'Dtc_Source(comdtc_Common)/list'* include 'Dtc_Source(apptdtc_Common)/list'c1 parameter idspp = 1, ! Function constants: Purge 1 idspu = 2, ! .. Unschedule 2 idspx = 3 ! .. eXchangecc byte line(1) ! input line6 byte temp(2), ll, ! temporary string converting array 1 ln1, ap1-5 integer eofflg, prveof, ! For RDAPPT 'do while' loop 1 firstflg  integer id, idx ! Julian Day integer im, imx ! Julian Month integer iye, iyx ! Julian YearpF integer it1, it2, itx1, itx2 ! time values 80 (8 AM) => 173 (5:30 PM)ct logical first ! For X decode' equivalence (line, ln1), (appoin, ap1)1c N include 'Dtc_Source(stmtfunc_Common)/list' ! Get standard statement functionsc Parse input line:/2c Was there a P on the front? If so, trim it off:cr1 isavinc = incmod ! Save for increment in DATCVT-- first = .true. ! Set it regardless of path- If ( ln1 .eq. 'P' ) theni) idisp = idspp ! Function to performt elset if (ln1 .eq. 'U') thenh idisp = idspu else if (ln1 .eq. 'X') then idisp = idspx* elsee$ go to 999 ! Error, can't decode it end if' it1 = 80 ! Set comparison values it2 = 180 itx1 = it1R itx2 = it2n End If call shrink (1, ifnb, lnb) if (ifnb .eq. 0) then if (idisp .eq. idspp) then'0 call dtcidate(im,id,iye) ! set to today's date elsee) go to 999 ! Not enough info for U or X end if  elseaca1c If the date was specified in command line thenl*c set id, im and iye to the right values:co$ 10 call dtcdatcvt(3) ! (line)+ if (first) then ! Note we decode intoi$ im = idmo ! second set of values,' id = iddy ! then copy into first set,- iye = ibigyr ! first (or only) time around 8 end if ! (unlike Schlitz, we can go around twice)2 if (idisp .ne. idspp) then ! other than purge2c *** itx2 = 175 ! Set default for '*' or  call dtctimcvt(itx1, itx2) if (itx1 .eq. itx2)tB 1 itx2 = itx2 + 1 ! Add (10 mins) to allow semi-open interval if (first) then  it1 = itx1 it2 = itx2 if (idisp .eq. idspx) then4 if (ln1 .eq. 0) go to 999 ! Error if nothing left first = .false. go to 10 ! Re-cycle code end if ! Done unless X end if( else ! P, guarantee no redisplay ln1 = "0 ! Zap the lineg$ end if ! Done parse for U, X" end if ! Done date/time parse= ixhash = ihymd(iye, im, id) ! Calc hash for day of interestwc *** type 950, ixhashc *** 950 format(2z9.8)r if (idisp .eq. idspp)) 1 then ! Set request date for RDAPPT* irqhash(1) = ixhash ! Delete before elseo) irqhash(1) = 0 ! Look at everybodym end ife1 irqhash(2) = '7FFFFFFF'X ! 'Til the end of time3 firstflg = 0 ! Zero until file opened for write- prveof = 0f eofflg = -1 do while (prveof .ge. 0)n9 call dtcrdappt(eofflg, 1) ! Look at control entriesh if (eofflg .gt. 0)E 1 thenN( eofflg = 0 ! Don't open it on return% go to 190 ! but re-write it as isH+ else if (eofflg .eq. 0) ! Test it now 1 thenac *** type 950, irchashm= iht = min0(max0(iht, 80), 173) ! Insure a kosher time value)9 go to (110, 120, 130) idisp ! Dispatch on numeric value * go to 190 ! Bad call, re-write anyway?% 120 if ((irchash .eq. ixhash) .and. - 1 ((iht .ge. it1) .and. (iht .lt. it2)))r8 2 go to 100 ! Criteria for Unscheduling (deleting) go to 190 ! Do re-write% 130 if ((irchash .eq. ixhash) .and.i- 1 ((iht .ge. it1) .and. (iht .lt. it2)))e 2 thene1 iht = itx1 + (iht - it1) ! Get updated timet> if (mod(iht, 10) .eq. 6) iht = iht + 4 ! go to next hour; if (iht .gt. itx2) go to 100 ! Duration was shortened " ihy = ibigyr ! Change dates ihm = idmo ihd = iddy end if ! Usually re-writec " 110 continue ! Purge, re-write4 190 if (firstflg .eq. 0) ! Can't open output till 1 then ! we have input!c close(2), open(unit=2, file=FNAME, status='NEW', 1 form='FORMATTED',n$ 1 carriagecontrol='LIST', err=999)% firstflg = 1 ! Output now open  end if$ write (2, 201) ihy, ihm, ihd, iht,- 1 apptstr(1:min0(max0(iaptln, 1), iaptlim))t:c *** 1 (appoin(k), k=1, min0(max0(iaptln, 1), iaptlim))? 201 format(i4.4, 2i2.2, i3.3, x, a) ! New format, 19850806113e end if ! eofflg. 100 prveof = eofflg ! Set loop condition end do ! while+ if (firstflg .eq. 0) ! Purged everything?= 1 then ! create empty file close(2)e+ open(unit=2, file=FNAME, status='NEW',( 1 form='FORMATTED',# 1 carriagecontrol='LIST', err=999)m$ firstflg = 1 ! Output now open end ifn close(2) ! Done with new file returnd; 999 write (iterm, 990) ! Error on decode, write nastygrams5 990 format('+Syntax or file-open (write) error.', $)d ln1 = "0 ! Inhibit rescanc  endww x x x x x. write (iterm,138) ! Mark double-width lines 1 esc,'[13H', esc,dwide, 2 esc,'[15H', esc,dwide, 3 esc,'[17H', esc,dwide, 4 esc,'[19H', esc,dwide, 5 esc,'[21H', esc,dwide, 6 esc,'[23H', esc,dwide 138 for y Subroutine TIMINC(Line,Incmod))!C ROUTINE TO ADD OR SUBTRACT TIME! BYTE LINE(84) INTEGER INCMODtC INCMOD = 1 FOR DAYC = 2 FOR WEEKC = 3 FOR MONTHC = 4 FOR YEAR. C FORMAT ISt-C +NN OR -NN : ADD/SUBTRACT NN DEFAULT UNITSi,C +/- NNU (U=D,W,M,Y) TO ADD/SUBT THAT UNIT INTEGER IDYR,IDMO,IDDYe COMMON/DEFDAT/IDYR,IDMO,IDDY C OUTPUT IN DEFDAT INTEGER ML(14) C LENGTH OF MONTHS INTEGER L(12) EQUIVALENCE(L(1),ML(2))3 DATA ML/31,31,28,31,30,31,30,31,31,30,31,30,31,31/,8C ML IS 14 LONG TO ALLOW REFS OUT OF BOUNDS TO L FOR NO.C DAYS IN MONTH... ISIGN=1 IF(LINE(1).EQ.'-')ISIGN=-1a+C SQUASH LINE DOWN AND MAKE SURE UPPER CASEb DO 1 N=1,83 LL=LINE(N+1)  IF(LL.GT.97)LL=LL-32b 1 LINE(N)=LL LINE(84)=0oC SCAN FOR D,W,M,Y FOR UNITS DO 2 N=1,80 IF(LINE(N).EQ.'D')THEN, INCMOD=1 LINE(N)=0e GOTO 3 ELSE IF (LINE(N).EQ.'W')THEN0 INCMOD=2 LINE(N)=0( GOTO 3 ELSE IF (LINE(N).EQ.'M')THEN' INCMOD=3 LINE(N)=0  GOTO 3 ELSE IF (LINE(N).EQ.'Y')THENo INCMOD=4 LINE(N)=0 GOTO 3 END IF/ 2 CONTINUE 3 CONTINUEC NOW GRAB OFF DIGITS... MAGN=0hC MAGN GETS MAGNITUDE TO GRABf DO 4 N=1,80 LL=LINE(N)  IF(LL.EQ.32)GOTO 4n IF(LL.GE.48.AND.LL.LE.57) THEN MAGN=10*MAGN+(LL-48) 0 ELSE  GOTO 5 END IFo 4 CONTINUE 5 CONTINUE IF(MAGN.EQ.0)MAGN=1?C MAGN NOW HAS MAGNITUDE, ISIGN HAS SIGN AND INCMOD HAS TYPE OFa C INCREMENT. IF(INCMOD.LE.2) THENc INCTYP=1 ELSEa INCTYP=INCMOD-13 END IFb6C INCTYP IS 1 FOR DAY OR WEEK, 2 FOR MONTH, 3 FOR YEAR IF(INCMOD.EQ.2)MAGN=MAGN*7 3C ADJUST WEEKS AS BEING 7 * DAYS AND TREAT TOGETHERy IF(INCTYP.EQ.1)THEN IDDY=IDDY+ISIGN*MAGNC LOOP POINT IF WE MOVE FORWARDt100 IF(IDDY.GT.L(IDMO)) THEN LYD=0n:C ACCOUNT FOR LEAP YEARS WHERE FEBRUARY IS 29 DAYS LONG...- IF(4*(IDYR/4).EQ.IDYR.AND.IDMO.EQ.2)LYD=1, IDDY=IDDY-L(IDMO)-LYDr IDMO=IDMO+1t IF(IDMO.GT.12)THEN IDMO=1 IDYR=IDYR+1 END IF GOTO 100 END IFC LOOP POINT IF WE MOVE BACK110 IF(IDDY.LE.0)THENAC ACCOUNT FOR LEAP YEARS. NOTE ML IS PREV MONTH SO CHECK DEF MO=3 LYD=0- IF(4*(IDYR/4).EQ.IDYR.AND.IDMO.EQ.3)LYD=1 IDDY=IDDY+ML(IDMO)+LYD IDMO=IDMO-1 IF(IDMO.LE.0)THEN IDMO=12 IDYR=IDYR-1 END IF GOTO 110 END IF ELSE IF(INCTYP.EQ.2)THEN IDMO=IDMO+ISIGN*MAGN200 IF(IDMO.GT.12)THEN IDMO=IDMO-12 IDYR=IDYR+1 GOTO 200 END IF300 IF(IDMO.LE.0)THEN IDMO=IDMO+12  IDYR=IDYR-1 GOTO 300 END IF ELSE IF(INCTYP.EQ.3)THENi IDYR=IDYR+ISIGN*MAGN END IFl RETURNe ENDwwnt and first non-blank character9c Performs no operation if current item is EOL (binary 0)Gc Sets return arguments pointing to first and last non-blank characters' subroutine shrink (iskip, ifnbr, lnbr)c include 'comdtc.inc/nolist' byte ll ifnb = 0 lnb = 01 if (line(1) .eq. 0) go to 999 ! Exit immediately! ix = iskip + 1 ! start looking3 do vyHc-----------------------------------------------------------------------ctc Week-at-a-glance subroutinecn"c part of Mitch Wyle's DTC programc9c Input:-c line - 72 byte string; Format: W [mmddyy] cl c Output:)c display screen (see below)lceHc-----------------------------------------------------------------------c+0c Modified 850117 to fix leap-year problems - CGAc Modified 850314 to use real corners, lines and T's for box - CGl?c Modified 850318 to display current date in reverse video - CG->c Modified 850806 to use new subroutines (including DTCRDAPPT)/c and get rid of previously commented-out codenc SUBROUTINE week ! (line)cMc Declarations:mc) include 'Dtc_Source(comdtc_Common)/list'* include 'Dtc_Source(apptdtc_Common)/list') include 'Dtc_Source(escdtc_Common)/list'dc $ byte ln1, ll ! equiv to input line2 byte temp(2) ! temporary string converting array& logical apts(7,19), aptsln(133), tflg integer prveof, eofflg INTEGER HASH integer id ! Julian Dayp integer im ! Julian Month  integer iy, iyd ! Julian Yearn3c lengths of months ... leap years adjusted in code-/ integer ml(14) ! December Jan ... Dec January; 1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/( equivalence (line, ln1), (apts, aptsln)+ include 'Dtc_source(stmtfunc_Common)/list' c Initialize:s4 iss = '7FFFFFFF'X ! Impossible saved Sunday day... iwf=0 ! Adjustment factorn! if ((ln1 .and. ucmask) .eq. 'W'), 1 call shrink(1, ifnb, lnb)8 call dtcidate(imx,idx,iyx) ! initialize to today's date$ call dtcdatcvt(3) ! Get date string im=idmo ! Copy values id=iddy iy=ibigyr if (islpyr(iy)) theny, ml(3)=29 ! Feb is in ML(3), not ML(2)!!! elsel$ ml(3)=28 ! C Garman, 17-Jan-1985 end ifr9C Where we look for free space of n units or more length,;C then just display reverse and zot out all shorter periodsu if (ctlfg .eq. 1) rdspfg=1) tflg = (rdspfg .ne. 0) ! initialize flagm do ij = 1, 7*19 aptsln(ij) = tflg end dom$ if (ctlfg .ne. 0) then ! Locate N intsz = 0 i = 1 do while(numeric(line(i)))i) intsz = (intsz * 10) + icvtbn1(line(i))s i = i + 1  if (i .gt. icmln) go to 1191 end doe-c clamp interval size to permissible range... * 1191 intsz = min0(max0(intsz, 1), 18) end ifcc Paint the screen:cpMc following sequence moves to upper left corner on VT100 compatible terminalsc and clears screen,) write(iterm,6) esc,homescrn, esc,clrscrni 6 format('+',4a,$):c Now write box, in graphics mode, to enclose days of week? write (iterm, 70), so, 'l', 'k', si ! Upper corners & top linec $ Do i = 1, 6 ! 6 more days' worth( write (iterm, 71), so, esc, esc, si write (iterm, 72), so, si end do3c 5 write (iterm, 71), so, esc, esc, si ! two more sidesB write (iterm, 73), so, 'm', 'j', si ! Lower corners & bottom lineci: 70 format ('+', 2a1, 77('q'), 2a1) ! Upper/lower corners$ 71 format (x, a1, 'x', a1, '[77Cx'/- 1 x, 'x', a1, '[77Cx', a1) ! sidest: 72 format (x, a1, 't', 77('q'), 'u', a1) ! interior lines8 73 format (x, 2a1, 77('q'), 2a1) ! Upper/lower corners call dtcat(2,2) write(iterm,10) ' Sunday' 10 format('+',a)  call dtcat(2,5) write(iterm,10) ' Monday' call dtcat(2,8) write(iterm,10) ' Tuesday' call dtcat(2,11)  write(iterm,10) 'Wednesday' call dtcat(2,14). write(iterm,10) ' Thursday' call dtcat(2,17)f write(iterm,10) ' Friday' call dtcat(2,20)u write(iterm,10) ' Saturday'c!Dc Now figure out which Sunday is closest to the day specified by id:cd? call dtcalcdow(ib,il,im,iy) ! Remember: ib = 1st day of month c il = length of month0c ib = day number of 1st day of month, 1=sunday. if ( ib .eq. 1 ) then0 is = 1 ! IS is the Sunday we want. It is* else ! either the 1st day of the month- is = 9 - ib ! or 9 - 1st day of month. end ifh(C Now...Sunday may be in preceding month2 11 continue ! If the day is not in the 1st week&c try to fix up case of wrong sunday..&c ML array is preceding month's length iwf=0 if (id .lt. is) thent is=is-7+ml(im) im=im-1l if (im .le. 0) thenc adjust year wrapback im=12 iy=iy-1 end if il=ml(im+1)e iwf=-il go to 301f end if.@ if ( ( id - is ) .ge. 7 ) then ! of the month, then keep adding2 is = is + 7 ! 7 until we get to the week we go to 11 ! want.1 end if1 301 c ontinuepKc since we can wrap months down as well as up construct date limits here...f"c *** if (iy .gt. 1900) iy=iy-1900Gc just generate a hashcode that is strictly increasing as a function offDc date. only purpose is to be monotonic increasing, so continuity isHc not important. we use other methods to handle exact offsets. note thatEc where wrap arounds occur, iss is allowed to be a little larger than Dc real month length or a small negative where used below...not here. irqhash(1) = ihymd(iy, im, is)o0 iss = is ! don't lose track of Sunday's date.- issss = is ! It will be important later...ncfBc Now figure out where to write the dates of the days of the week,%c and write em out where they belong:ocu) iyd = mod(iy, 100) ! Display two digits Do i=1,7 jy = 3 * i, call dtcat(2,jy)W0 if ((im .eq. imx) .and. (iy .eq. iyx)) then if (is .eq. idx) theni1 if (id .eq. idx) then ! reverse + underlinet write(iterm,130,err=99). 1 esc,'[4;7m', im,is,iyd, esc,resetvattr else ! reverse only, write(iterm,130,err=99). 1 esc,revattr, im,is,iyd, esc,resetvattr end if else go to 684  end if elsep, 684 if (is .eq. id) then ! underline only write(iterm,130,err=99)e( 1 esc,'[4m', im,is,iyd, esc,resetvattr" else ! N/O/T/A, nothing fancy& write(iterm,13,err=99) im,is,iyd end if end ifT 99 is = is + 1l3 If ( is .gt. il ) then ! Did the month change  is = 1 ! during this week? im = im + 1i/ If ( im .gt. 12 ) then ! Did the year changer" im = 1 ! during this week? iy = iy + 1i iyd = mod(iy, 100) End If End Ifi> irqhash(2) = ihymd(iy, im, is) ! save last day value in hash end do' 13 format('+', i3, '/', i2.2,'/',i2.2)6 130 format('+', a1, a, i3, '/', i2.2,'/',i2.2, a1, a)cc Now for Files I/O:c9c Set up a boolean array of appointment times and days of8c the week. Notice that if this program were written in6c assembler, we would use only 18 bytes and store this8c information by bits instead of bytes. Oh well. There$c goes 100 bytes of storage space...5c When life confronts you with its troubles and woes, *c Have no fear, just fire photon torpedos!cUc,9c Read the appointments; If the appointment is for one ofM;c the days in this week, mark that spot in the appointments4=c array true. Otherwise that coordinate is false. The array)c looks like this:c3c Su Mo Tu We Th Fr Sa,c:c 8:00 T F F F F F F ! Appointment on Su at 8:00Cc 8:30 F T T T F F F ! Appointments on Mo, Tu, We at 8:30LBc 9:00 F F F F F F F ! No appointments at 9:00 this weekc 9:30cLc . . . . . . . .N#c . . . . . . . . etceteraSc . . . . . . . ..c ! sic itur ad astra cE6c Etcetra. Caveat emptor and three other latin words.c2c prveof = 0 eofflg = -1 do while (prveof .ge. 0)N; call dtcrdappt(eofflg, 0) ! Look at appointments file if (eofflg .ge. 0) 1 thenIDC NOW we are testing the date range validly. However, we must adjust8C the ISS range to be in the range from - (small #) to +>C (or some such) to take into account the fact that it MUST be>C continuous in order to be transformed into a cursor address.AC FORTUNATELY we saved the appropriate length of month adjustmentI6C above so can add it back in here. IWF=0 most times. iss=issss+iwf jx = ihd - iss + 1 !9c need a little more logic to handle crossing months here?c where jx >7 we have to adjust by length of month once more...D if (jx .gt. 7) jx=jx+iwfAc also have to handle cases where we crossed months, by adding inc length of previous month.E if (jx .le. 0) jx=jx+ml(im)E( jy = min0(max0(((iht+2)/5)-15, 1), 19)) if ((jx .ge. 1) .and. (jx .le. 7) .and.=& 1 (jy .ge. 1) .and. (jy .le. 19)) 2 then 9 apts(jx,jy) = .not. tflg ! Derived a long time ago!N D elseO1D write(iterm,7700)jx,jy,ihd,iht,iss,ihy,ihmI8D7700 format(' X,Y=',2I4,' Day, tim, ISS, yr, mo= ',5I6) end if end if prveof = eofflg end do ! whileOc.1c Now display the information we have extracted:-c if (ctlfg .ne. 0) then :c here go through and look for "intsz" sized intervals and:c set apts(i,j) to .false. if the interval is too small... k=19-intsz. Do i=1,7D Do j=1,k ivl=1+ Do l=1,intsz! if (.not. apts(i,j+l-1)) ivl=0 end do( if (ivl .ne. 1) apts(i,j)= .false. end doEc since we are showing valid start times, set all times at the end of@c the day false since they can't possibly be valid times for any c meetings. kk=k+1 if (kk .le. 18) then do j=kk,18 apts(i,j)= .false. end do end if end do End If$ Do i=1,7 ! Go through the entire% Do j=1,19 ! array and display/ If ( apts(i,j) ) then ! appts if they exist:0 jx = 6 * j + 10 ! jx is x coord of cu yHc-----------------------------------------------------------------------cc Year-at-a-glance subroutinec"c part of Mitch Wyle's DTC programc c Input: +c line - 72 byte string; Format: Y [yy]c c Output:c display screen (see below)cHc-----------------------------------------------------------------------c SUBROUTINE year ! (line)c Declarations:G) include 'Dtc_Source(comdtc_Common)/list's) include 'Dtc_Source(escdtc_Common)/list'o6 b yte temp(4), ln1 ! temporary string converting array integer id, idr ! Julian Day integer im, imr ! Julian Month integer iye, iyr ! Julian Year4 integer iyo ! y offset for where to put month data integer ix ! x coord of cursor integer iy ! y coord of cursor2 integer img ! month loop index goes from 1 to 12* integer jg ! index offset defined by img- integer ii ! implied do loop index variablea$ byte monthn(9) ! string month name/ real badf77 ! Maybe error in array subscripts= character*21 wknam ! string containing names of days of week 1 / 'Su Mo Tu We Th Fr Sa|'/y real badftn ! Hoolay kan byte ihold ! hold the screen@ logical*1 lmneven(12)/ ! Entries true if length of name is even6 1 .false., .true., .false., .false., .false., .true.,6 2 .true., .true., .false., .false., .true., .true./ equivalence (line, ln1)! if ((ln1 .and. ucmask) .eq. 'Y')t 1 call shrink(1, ifnb, lnb)+ call dtcdatcvt(1) ! Parse out a year valuen im=idmo id=iddy  iye=ibigyr ct8 call dtcidate(imr,idr,iyr) ! initialize to today's date" ! to display in reverse videocyc Paint the screen:cyMc following sequence moves to upper left corner on VT100 compatible terminals8c and clears screen-) write(iterm,6) esc,homescrn, esc,clrscrna 6 format('+',4a,$) 7 write(iterm,300) esc,'[?3h', ! set screen to 132 cole0 1 esc,'[2H', esc,'#6', ! set double width for) 2 esc,'[14H', esc,'#6' ! Month headersj! encode (4, 20, temp, err=97) iye 20 format(i4) 97 ix = 29t iy = 11& call dtcat(ix,iy) ! Display year in> write(iterm,305) esc,dhdw1, temp ! double height/double width# ! in the middle of the screen. iy = 12 call dtcat(ix,iy)/ write(iterm,305) esc,dhdw2, temp ! second line.' 99 Do 4 img = 1,12 ! for each month:,? call dtcmthnam(img,monthn) ! Find out name, and display itu0 jg = img - 1 ! x coord of cursor for month4 if (jg .gt. 5) jg = jg - 6 ! name in outstring ix = ( jg * 22 ) + 1 !63 if (img .gt. 6) then ! First six months on topd' iy = 14 ! last six months on bottomr else ! half of screen iy = 2 end if ixx = (ix/2) + 2 )c *** if (lmneven(img)) ixx = ixx + 1o/ call dtcat(ixx,iy) ! Position cursor and:e write(iterm,3) monthn. 3 format('+',21a1) ! Write out the name. 300 format('+',40a)! 305 format('+', 2a, 4(x, a))/ 399 format('+',a21) ! Write out the name.w1 If (img .gt. 6) then ! Write out day of week1$ iy = 15 ! Header names also, one$ else ! line below month names iy = 3 end ifl call dtcat(ix,iy) write(iterm,399) wknamr1 If (img .gt. 6) then ! Write out numbers forn! iy = 15 ! Days in each month:a iyo = 12 else) iy = 4 iyo = 0t end ifi; call dtcalcdow(ib,il,img,iye) ! Now position the month)* ix = ix - 1 ! Off by 1. CORRECT IT ixspa = 0 ixo = 0 iyspa = 0- call dtcdspmth(ib,il,ix,ixspa,iyo,iyspa)e@c If displaying current year, mark today's date in reverse video2 if ((iye .eq. iyr) .and. (img .eq. imr)) then- idw = mod(ib + idr -2, 7) ! Day of week and2 iwm = (idr + ib - 2)/7 ! week of month (orig 0)@ if (img .gt. 6) iwm = iwm + 1 ! Down one more line for Jul-Dec* call dtcat((idw * 3) + ix + 1, iy + iwm)6 write (iterm, 301), esc,'[5;7m', idr, esc,resetvattr! 301 format ('+', 2a, i2, 2a, $) end if 4 Continuen( call dtcat (1,23) ! Reposition cursor:c return next line read in and allow main pgm to decode... read(5,80,END=914)linen 80 format(84a1) 914 write(iterm,300) esc,'[?3l' endww) im=im-1 if (im .le. 0) thenc adjust year wrapback im=12 iy=iy-1 end if il=ml(im+1) iwf=-il go to 301 end if@ if ( ( id - is ) .ge. 7 ) then ! of the month, then keep adding2 is = is + 7 ! 7 until we get to the week we go to 11 ! want. end if 301 continueKc since we can wrap months down as well as uK{Hc-----------------------------------------------------------------------cec Daily Appointment subroutinecu"c part of Mitch Wyle's DTC programcb c Input: Hc line - 72 bytes; Format: D [mmddyy [hh:mm>HH:MM [appointment]]]c c Output:tc display screen (see below)ncoHc-----------------------------------------------------------------------CaHc Modified 850314, CG, to write day-of-week to daily-appointment screen,Cc and note current time if current day displayed (reverse video) Ic Modified 19850802, CG, to write full date as well, and handle both new-e&c and old-format appointment files. SUBROUTINE day ! (line)c Declarations:0) include 'Dtc_source(comdtc_Common)/list'j* include 'Dtc_source(apptdtc_Common)/List') include 'Dtc_Source(escdtc_Common)/list'  character*100 apstr Character*50 Double_Quote ? + /' " " " " " "'/;' byte appnt(icmln) ! appointment stringe; byte temp(2), ll, ln1, ! temporary string converting arraye 1 ap1, byte blot/26/ ! ^Z, for entry from display integer id, idr ! Julian Day integer im, imr ! Julian Month integer iye, iyr ! Julian Yearr5 integer idx, imx, iyx, isx ! copies for calling DANYr integer eofflg/@ real*8 daylist(7) / ' Sun', ' Mon', ' Tues', ! uses A6 fmt@ 1 'Wednes', ' Thurs', ' Fri', ' Satur' / ! 'day' is in format character*9 mthlist(12)7 1 /' January', ' February', ' March', ' April',i7 2 '  May', ' June', ' July', ' August',!7 3 'September', ' October', ' November', ' December'/y- equivalence (line, ln1), (apstr, appnt, ap1)h+ include 'Dtc_Source(stmtfunc_Common)/list' c Initialize: 0 if ((ln1 .and. ucmask) .eq. 'D') ! leave = or * 1 call shrink(1, ifnb, lnb) + call dtcdatcvt(3) ! Pick off a date valuee im=idmo id=iddy iye=ibigyr ? call dtcalcdow (isx, imx, im, iye) ! Get day-of-week for B/O/Mr6 idx = mod (id + isx - 2, 7) + 1 ! Calc current d/o/w1 call dtcidate(imr, idr, iyr) ! Get today's datee/ if ((im .eq. imr) .and. ! if current = today, - 1 (id .eq. idr) .and. ! flag current timeo2 2 (iye .eq. iyr)) then ! Displaying current dayA scnds = amax1(secnds(0.), 28801.) ! Get current time (>8 AM) D ihalf = mod(ifix(scnds/1800.), 48) ! current half-hour (orig 0)$ ihour = ihalf/2 ! Current hour5 ihalf = ihalf - (ihour*2) ! 0 or 1 for half-hourT else& ihour = 0 ! Set non-match value endifKc ************************** Move the cursor to top of screen and clear it,89c ************************** set up appointments display::) write(iterm,4) esc,homescrn, esc,clrscrn  4 format('+', 4a, $). write(iterm,5) '+', esc,dhdw1, ( 1 daylist(idx), mthlist(im), id, ibigyr8 5 format(3a,'Schedule - ', a6,'day, ', a9, i3, ',', i5) write(iterm,5) ' ', esc,dhdw2, ( 1 daylist(idx), mthlist(im), id, ibigyr Do i=8,16 If ( i .gt. 12 ) then j = i - 12 Elsee j = i.  End Ift6 if (i .ne. ihour) then ! Check for highlighting write(iterm,6) j 6 format(x,i2,':00 -') write(iterm,7) j 7 format(x,i2,':30 -')$ else ! must be current hour, if (ihalf .eq. 0) then ! Check which half5 write(iterm,96), esc,revattr, j, esc,resetvattrp write(iterm,7) j else write(iterm,6) j5 write(iterm,97), esc,revattr, j, esc,resetvattr endifi( 96 format (x, 2a, i2,':00 -', 2a)( 97 format (x, 2a, i2,':30  -', 2a) endif end dos4 if (ihour .ge. 17) then ! Highlight 'Evening' line1 write(iterm,98), esc,revattr, esc,resetvattrd, else ! Includes display other than today write(iterm,9)  end ifm' 9 format(x, 'Evening:', /, x, 78('=')),1 98 format(x, 2a, 'Evening: ', 2a, /, x, 78('='))4c ******************* Screen has now been displayed,Ec ******************* now check rest of line for time and appointment3 if (ln1 .ne. 0) then ! More characters available?0 iht = 80 ! Default is 8>5( ihmx = 170 ! (18 entries for '*')= call dtctimcvt(iht, ihmx) ! Decode time value if presents y- ihh1 = (iht+2)/5 ! Adds 1 if trailing 3c, ihh2 = (ihmx+2)/5 ! Result is 16 to 354 idmx = min0(max0(ihh2-ihh1, 1), 20) ! 8:00>6:00Hc Note: range of h1:00>h1:30 is considered only one scheduling interval,Ac similarly h(1)>h(2) is an even number, ending just before h(2),-:c computation forces at least one for interval h1:00>h1:00 ifnb = 0 lnb = 0 ivx = 0* ap1 = 0 ! Clear appointment string do i = 1, icmln ll = line(i) appnt(i) = llr# if (ll .eq. 0) go to 6789 ! done.# ivx = i ! Save current length( end do)c Was there an appointment string input?3c If so, put it in file, and display it on screen.,1c If not, move cursor to correct time on screen, =c then input the appointment, put in file and re-display it.d>c and when the band you're in starts playing different tunes,-c I'll see you on the dark side of the moon. : 6789 If (ap1 .eq. 0) then ! Empty appointment string4 iy = ihh1 - 13 ! Vertical position for half hour ix = 11d call dtcat(ix,iy)!5 write(iterm, 987) blot, esc,'[D' ! write, backspace  987 format ('+', 3a, $) " read(5,13,END=914) lapp, workstr 13 format(q,a)#c copy appointment for use later... ifnb = 0 lnb = 0 ivx = 0  Do i = 1, lapp& ll = work(i) ! fetch character if (ll .gt. ' ') thene3 if (ifnb .eq. 0) ifnb = i ! Flag first non-blankf# lnb = i ! Flag last non-blank end if3 if (ifnb .ne. 0) then ! Copy after first n/b  ivx = ivx + 1 appnt(ivx) = ll end if end do6 if (ifnb .eq. 0) go to 914 ! Nothing on read either End If6 ivx = min0(ivx, iaptlim) ! ivx = length of string iwy=iye iwm=im iwd=id iwht=ihtNC If we are using the 'S' command, add meetings to the indirected files ONLY,%C not to the current (control) file.-7 if (ctlfg .ne. 1) then ! Add appointment if D or G- close (1) ! Insurance= Open ( unit=1,file=FNAME,status='UNKNOWN',form='FORMATTED',24 1 carriagecontrol='LIST', access='APPEND',err=9876) ihtxx=ihte do ixx = 1, idmx + 1. write(1,14) iye,im,id,ihtxx,apstr(1:ivx) Apstr=Double_Quote If(ivx.gt.50) ivx=50# if ((ihtxx/10)*10 .eq. ihtxx)n 1 thene9 ihtxx=ihtxx+3 ! IHT is even hour, go to next half hour else> ihtxx=ihtxx+7 ! IHT is a half hour ... make up to next hour end if end do 14 format(i4.4,2i2.2,i3.3,x,a) 9876 close(1)t End Ifr- else ! Empty line (no appointment to add)o2 914 idmx = 0 ! Use as flag for display only end ifi eofflg = -1 ! Request OPEN prveof = 0 ! Set for DO WHILE lookind = 0= if (ctlfg .ne. 0) lookind = 1 ! Set for looking at filenamesb; irqhash(1) = ihymd(iye, im, id) ! Set match for file scana) irqhash(2) = irqhash(1) ! One day onlyu do while (prveof .ge. 0)n$ call dtcrdappt(eofflg, lookind)8 if (eofflg .eq. 1) ! Returned with filename string 1 thennIc on scheduling multiple dates via S or G functions, use this occasion to -c add the record to everyone's calendar file.n close(2)4 Open (unit=2, file=work(istart), status='UNKNOWN',0 1 form='FORMATTED', carriagecontrol='LIST',! 2 access='APPEND', err=1119) ihtxx=iwht do ixx = 1, idmx0 write(2,14) iwy,iwm,iwd,ihtxx,apstr(1:ivx)( if ((ihtxx/10)*10 .eq. ihtxx) then< ihtxx=ihtxx+3 ! iht is an even hour ... add the half hour else> ihtxx=ihtxx+7 ! iht is a half hour ... make up to next hour end if end do 1119 close(2)$0c Display appointment if it matches current date else If (eofflg .eq. 0) 1 thenoF iy = min0(max0((((iht+2) / 5) - 13), 3), 22) ! Compute vertical posn ix = 107 if (appoin(1) .ne. ' ')9 1 then) ix = 11 ! '12:00 - Appointment'a elseH if (iaptln .le. 1) appoin(1) = blot ! Display BLOT for empty entry end if kk = min0(iaptln, iaptlim) call dtcat(ix,iy)mC*C* BHZC* idot = index(apptstr,'!>') ilen = len(apptstr)a if (idot .gt. 0) thenh, apptstr(1:ilen-2) = apptstr(1:idot-1) // 1 apptstr(idot+2:ilen)o; write(iterm,350) esc,hilight,apptstr(1:kk),esc,lolight,n 1 esc,'[K' g 350 format('+',a,$) else 8 write(iterm,300) apptstr(1:kk), esc,'[K' ! Erase EOL 300 format('+', 3a, $) endifeC*C* BHZC* End If ! eofflg .ge. 0* prveof = eofflg ! Show what happened end do ! while (prveof)t call dtcat(1,22)  endww3) monthn. 3 format('+',21a1) ! Write out the name. 300 format('+',40a)! 305 format('+', 2a, 4(x, a))/ 399 format('+',a21) ! Write out the name.1 If (img .gt. 6) then ! Write out day of week$ iy = 15 ! Header names also, one$ else ! line below month names iy = 3 end if call dtcat(ix,iy) write(iterm,399) wknam1 If (img .gt. 6) then ! Write out numbers for! iy = 15 ! Days in each month: iyo = 12 else iy = 4 iyo = 0 end if; call dtcalcdow(ib,il,img,iye) ! Now position the month* ix = ix - 1 ! Off by 1. CORRECT IT ixspa = 0 ixo = 0 iyspa = 0- call dtcdspmth(ib,il,ix,ixspa,iyo,iyspa)@c If displaying current year, mark today's date in reverse video2 if ((iye .eq. iyr) .and. (img .eq. imr)) then- idw = mod(ib + idr -2, 7) ! Day of week and2 iwm = (idr + ib - 2)/7 ! week of month (orig 0)@ if (img .gt. 6) iwm = iwm + 1 ! Down one more line for Jul-Dec* call dtcat((idw * 3) + ix + 1, iy + iwm)6 write (iterm, 301), esc,'[5;7m', idr, esc,resetvattr! 301 format ('+', 2a, i2, 2a, $) end if 4 Continue( call dtcat (1,23) ! Reposition cursor:c return next line read in and allow main pgm to decode... read(5,80,END=914)line 80 format(84a1) 914 write(iterm,300) esc,'[?3l' endww@¨pc Begin common APPTDTC.INC- parameter iwrkln = 100 ! Can't use it below character*100 workstr character*84 apptstr ! icmln5 integer irqhash(2), ! Range of hash values (input)? 1 irchash, ihy, ihm, ihd, iht, iaptln, istart, iwkln ! outputs! byte appoin(icmln), work(iwrkln)7 common /apptdtc/ irqhash, irchash, ihy, ihm, ihd, iht,, 1 iaptln, istart, iwkln, workstr, apptstr/ equivalence (apptstr, appoin), (workstr, work)c End common APPTDTC.INCww@*2p7c Common file COMDTC.INC for Desk Top Calendar programsc+ parameter iterm = 6 ! Terminal unit numberc4 parameter icmln = 84, ! Length of character buffers2 1 iaptlim = 68 ! maximum displayed lengthc& integer comlen, comidx ! Current info byte line(icmln) ! command line% common /cmdlin/ comlen, comidx, linec? integer tokstart, toklen, tokfidx ! Command-line scanning info' byte tokfound ! for multi-token scans5 common /cmdscan/ tokstart, toklen, tokfidx, tokfoundcD integer rdspfg ! flag to reverse sense of display of time3 integer ctlfg ! misc control flags here common /ctls/ rdspfg, ctlfgc) integer idyr, idmo, iddy, incmod, ibigyr1 common /defdat/ idyr, idmo, iddy, incmod, ibigyrc! integer fnsz ! Size of filename byte fname(60) common /fn/ fnsz, fnamec% byte ucmask/'5f'x/ ! Useful constantcc End of COMDTC.INCww MMON&}p PHIL ESCDTC_COMMON)p PHIL DEFCENTRY_COMMON) Ԣp PHIL DTCXIDATE_COMMON'|(p PHIL INCCENT_COMMON(p PHIL STMTFUNC_COMMON'Opq PHIL CNVT_TO_MMDDYY`;r PHIL DAY r PHIL DANY@r PHIL DATMUN!Mr PHIL DHELPVAX"@ɰ$s PHIL DTCALCDOW`s PHIL DTCAT"s PHIL DT`p7c Common file ESCDTC.INC for Desk Top Calendar programsc3 character*2 homescrn, clrscrn, ! Special sequences& 1 dhdw1, dhdw2, dwide, resetvattr character*3 revattr,lolight character*5 hilight/ common /vidstuff/ homescrn, clrscrn, ! Greasy?; 1 dhdw1, dhdw2, dwide, resetvattr, revattr,hilight,lolightcKc Compiler will usually treat these as constants, so don't really need themc to be in commonc byte esc /"033/, ! ASCII escape? 1 so /"016/, ! ^N, Shift-Out (enter graphics mode w/ ')0')= 2 si /"017/ ! ^O, Shift-In (exit graphics mode w/ '(B')cc End of ESCDTC.INCwwBp* parameter icntry = 1900 ! Default centurywwpFc *** Common file DTCXIDTATE for dummy IDATE subroutine of DTC programC integer xim, xid, xiy, xibgyr ! Month, day, year (yy), year (yyyy)& common /xidate/ xim, xid, xiy, xibgyrc *** End DTCXIDATE.INCwwp; include 'defcentry.inc/list' ! Common parameter with DANYwwopc Useful statement functions:&c 1) type checking of single character;c 2) quick binary to 2-digit bcd conversion, and vice versa$c 3) Check for leap-year (Gregorian)*c 4) Hashdate for DTC appointment matchingc7 logical numeric, chnumeric, ! Character type checking 1 lcalpha, alpha, 2 islpyr ! value check byte ch ! Single argument character*1 chch0 integer*2 icvtbcd, ich2 ! Conversion routines= integer icvtbin, icvtbn1, inum, ihymd, ! Compilation defa ult 1 izyr, izmo, izdy ! ..c0 numeric(ch) = (ch .GE. '0') .AND. (ch .LE. '9')8 chnumeric(chch) = (chch .GE. '0') .AND. (chch .LE. '9')0 lcalpha(ch) = (ch .GE. 'a') .AND. (ch .LE. 'z')( alpha(ch) = ((ch .AND. '5f'x) .GE. 'A')( 1 .AND. ((ch .AND. '5f'x) .LE. 'Z')c? icvtbcd(inum) = ((MOD(inum, 10) * 256) .OR. inum/10) .OR. '00', icvtbin(ich2) = ((ich2 .AND. '000F'X) * 10)C 1 + ((ich2 .AND. '0F00'X)/256) ! Works w/space as first char9 icvtbn1(ch) = ch .AND. '0F'X ! Conve rt single characterc, islpyr(izyr) = (mod(izyr, 400) .EQ. 0) .OR.8 1 ((izyr .AND. 3) .EQ. 0) .AND. (mod(izyr, 100) .NE. 0)c= ihymd(izyr, izmo, izdy) = (((izyr * 16) + izmo) * 32) + izdycc End statement functionsww`oq:C=========================================================C Cnvt_to_MMDDYYC5c Function: Edit a line starting with a date of form#c mm/dd/yy, mmddyy, or dd-MMM-yyc into one with a date of form c mmddyycCC CALL Cnvt_To_MMDDYY(Line)CC Where BYTE Line(9)C'C Line servers both as input and output*C Converted from G. Everhart's DTC versionC- OPTIONS /NOI4$ Subroutine Cnvt_to_MMDDYY(line,Ier) Byte line(9),work(9) byte l1,l2,l3 Ier=0 ! assume success do 1 n=1,65 if(line(n).eq.'/') goto 100 ! If in mm/dd/yy form6 if(line(n).eq.'-') goto 200 ! If in dd-mmm-yy form 1 continue' Return ! Format Ok, Return leaving ! the line alone C ------------------------------/100 continue ! convert mm/dd/yy into mmddyy if(line(2).eq.'/') then work(1)='0' work(2)=line(1) k=3 else work(1)=line(1) work(2)=line(2) k=4 end if if(line(k+1).eq.'/')then work(3)='0' work(4)=line(k) kk=k+2 else work(3)=line(k) work(4)=line(k+1) kk=k+3 end if work(5)=line(kk) work(6)=line(kk+1)5c set up pointers to next element of line (i.e., kkk)c for copy of rest of stuff. kkk=kk+2 goto 300C ----------------------------/200 continue ! Convert dd-mmm-yy into mmddyy if(line(2).eq.'-')then work(3)='0' work(4)=line(1) k=3 else work(3)=line(1) work(4)=line(2) k=4 end if work(5)=line(k+4) work(6)=line(k+5) kkk=k+65c now have pointers, but month needs to be filled in.3c note we assume year always is entered as 2 digitsc and month is 3 chars... if(line(k+3).ne.'-')then work(1)=0(c zero stuff to pass if not 3 char month work(2)=0 goto 300 end if kk=k+3 do 220 n=k,kk nn=line(n)c mask off 32 (dec) bit toc make letters uppercase nn=nn.and.223 line(n)=nn 220 continue l1=line(k) l2=line(k+1) l3=line(k+2)c decode months the hard way work(1)='0' work(2)='0' IF(L1.EQ.'J'.AND.L2.EQ.'A')THEN WORK(2)='1' GOTO 300 ELSE IF(L1.EQ.'F')THEN WORK(2)='2' GOTO 3003 ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'R')THEN WORK(2)='3' GOTO 300% ELSE IF(L1.EQ.'A'.AND.L2.EQ.'P')THEN WORK(2)='4' GOTO 3003 ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'Y')THEN WORK(2)='5' GOTO 3003 ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'N')THEN WORK(2)='6' GOTO 3003 ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'L')THEN WORK(2)='7' GOTO 300% ELSE IF(L1.EQ.'A'.AND.L2.EQ.'U')THEN WORK(2)='8' GOTO 300 ELSE IF(L1.EQ.'S')THEN WORK(2)='9' GOTO 300 ELSE IF(L1.EQ.'O')THEN WORK(1)='1' GOTO 300 ELSE IF(L1.EQ.'N')THEN WORK(1)='1' WORK(2)='1' GOTO 300 ELSE IF(L1.EQ.'D')THEN WORK(1)='1' WORK(2)='2' GOTO 300 ELSE+ Ier=-1 ! Unrecognized month, warn user c WORK(1)=0 c WORK(2)=0 END IF goto 300 300 continuec common clean-up & return9 do 320 n=1,6 ! Copy edited string back for further work320 line(n)=work(n) Line(7)=' ' Line(8)=' ' Line(9)=' ' return endww Default is 8>5( ihmx = 170 ! (18 entries for '*')= call dtctimcvt(iht, ihmx) ! Decode time value if present - ihh1 = (iht+2)/5 ! Adds 1 if trailing 3, ihh2 = (ihmx+2)/5 ! Result is 16 to 354 idmx = min0(max0(ihh2-ihh1, 1), 20) ! 8:00>6:00Hc Note: range of h1:00>h1:30 is considered only one scheduling interval,Ac similarly h(1)>h(2) is an even number, ending just before h(2),:c computation forces at least one for interval h1:00>h1:00 ifnb = 0 lnb =  0 ivx = 0* ap1 = 0 ! Clear appointment string do i = 1, icmln ll = line(i) appnt(i) = ll# if (ll .eq. 0) go to 6789 ! done# ivx = i ! Save current length end do)c Was there an appointment string input?3c If so, put it in file, and display it on screen.1c If not, move cursor to correct time on screen,=c then input the appointment, put in file and re-display it.>c and when the band you're in starts playing different tunes,-c I'll see you on the dark side of the moon.: 6789 If (ap1 .eq. 0) then ! Empty appointment string4 iy = ihh1 - 13 ! Vertical position for half hour ix = 11 call dtcat(ix,iy)5 write(iterm, 987) blot, esc,'[D' ! write, backspace 987 format ('+', 3a, $)" read(5,13,END=914) lapp, workstr 13 format(q,a)#c copy appointment for use later... ifnb = 0 lnb = 0 ivx = 0 Do i = 1, lapp& ll = work(i) ! fetch character if (ll .gt. ' ') then3  if (ifnb .eq. 0) ifnb = i ! Flag first non-blank# lnb = i ! Flag last non-blank end if3 if (ifnb .ne. 0) then ! Copy after first n/b ivx = ivx + 1 appnt(ivx) = ll end if end do6 if (ifnb .eq. 0) go to 914 ! Nothing on read either End If6 ivx = min0(ivx, iaptlim) ! ivx = length of string iwy=iye iwm=im iwd=id iwht=ihtNC If we are using the 'S' command, add meetings to the indirected files ONLY,%C not to the current (control) file.7 if (ctlfg .ne. 1) then ! Add appointment if D or G close (1) ! Insurance= Open ( unit=1,file=FNAME,status='UNKNOWN',form='FORMATTED',4 1 carriagecontrol='LIST', access='APPEND',err=9876) ihtxx=iht do ixx = 1, idmx + 1. write(1,14) iye,im,id,ihtxx,apstr(1:ivx) Apstr=Double_Quote If(ivx.gt.50) ivx=50# if ((ihtxx/10)*10 .eq. ihtxx) 1 then9 ihtxx=ihtxx+3 ! IHT is even hour, go to next half hour  else> ihtxx=ihtxx+7 ! IHT is a half hour ... make up to next hour end if end do 14 format(i4.4,2i2.2,i3.3,x,a) 9876 close(1) End If- else ! Empty line (no appointment to add)2 914 idmx = 0 ! Use as flag for display only end if eofflg = -1 ! Request OPEN prveof = 0 ! Set for DO WHILE lookind = 0= if (ctlfg .ne. 0) lookind = 1 ! Set for looking at filenames; irqhash(1) = ihymd(iye, im, id) ! Set match for file scan) irqhash(2) = irqhash(1) ! One day only do while (prveof .ge. 0)$ call dtcrdappt(eofflg, lookind)8 if (eofflg .eq. 1) ! Returned with filename string 1 thenIc on scheduling multiple dates via S or G functions, use this occasion to-c add the record to everyone's calendar file. close(2)4 Open (unit=2, file=work(istart), status='UNKNOWN',0 1 form='FORMATTED', carriagecontrol='LIST',! 2 access='APPEND', err=1119) ihtxx=iwht do ixx = 1, idmx0  write(2,14) iwy,iwm,iwd,ihtxx,apstr(1:ivx)( if ((ihtxx/10)*10 .eq. ihtxx) then< ihtxx=ihtxx+3 ! iht is an even hour ... add the half hour else> ihtxx=ihtxx+7 ! iht is a half hour ... make up to next hour end if end do 1119 close(2)0c Display appointment if it matches current date else If (eofflg .eq. 0) 1 thenF iy = min0(max0((((iht+2) / 5) - 13), 3), 22) ! Compute vertical posn ix = 10 if (appoin(1) .ne. ' ') 1 then) ix = 11 ! '12:00 - Appointment' elseH if (iaptln .le. 1) appoin(1) = blot ! Display BLOT for empty entry end if kk = min0(iaptln, iaptlim) call dtcat(ix,iy)C*C* BHZC* idot = index(apptstr,'!>') ilen = len(apptstr) if (idot .gt. 0) then, apptstr(1:ilen-2) = apptstr(1:idot-1) // 1 apptstr(idot+2:ilen); write(iterm,350) esc,hilight,apptstr(1:kk),esc,lolight, 1 esc,'[K'  350 format('+',a,$) else 8 write(iterm,300) apptstr(1:kk), esc,'[K' ! Erase EOL 300 format('+', 3a, $) endifC*C* BHZC* End If ! eofflg .ge. 0* prveof = eofflg ! Show what happened end do ! while (prveof) call dtcat(1,22) endww*c --- comlin = ' ' ! Initialize w/ blanksCC%C read (5, 7, end=999) comlen, comlinC 7 format(q, a) C - BHZ - write(5,7) 7 format (' ')C istatus = smg$read_string(ikeyid,comlin,' DTC: ',,,,,comlen,itchr)$c Mark only stuff read from terminal9c (don't want command-input call to try to read terminal)< line(min0(comlen+1, icmln)) = "0 ! mark for old-style tests go to 1$ 999 continue ! EXit, Quit, or ^Z endww CLOSE(Unit=2,DISPOSE='KEEP') !> CALL LIB$SPAWN('$LQ/DEL '//Cout_File) ! print/delete it END IF END IF GOTO 9999!8000 WRITE(*,8010)Cnull,Cesc,Cesc?8010 FORMAT(A,A,'[24;1HDTC -- Invalid date format, Try again', - A,'[23;1H',$) GOTO 999958020 WRITE(*,8025)Cnull,Cesc,(Fname(I),I=1,fnsz),CescC8025 FORMAT(A,A,'[24;1HDTC -- Appointment file can not be read: ',$ - A1,A,'[23;1H',$) RETURN!8030 WRITE(*,8040)Cnull,Cesc,Cesc=8040 FORMAT(A,A,'[24;1HDTC -- Invalid print command format', - A,'[23;1H',$) GOTO 9999!8050 WRITE(*,8060)Cnull,Cesc,Cesc@8060 FORMAT(A,A,'[24;1HDTC -- Expected second date is missing', - A,'[23;1H',$) GOTO 9999!8070 WRITE(*,8080)Cnull,Cesc,Cesc58080 FORMAT(A,A,'[24;1HDTC -- Invalid date format. ',A - 'Dates must start with numbers',A,'[23;1H',$) GOTO 9999!8090 WRITE(*,8100)Cnull,Cesc,Cesc48100 FORMAT(A,A,'[24;1HDTC -- Invalid month name. ',?  - 'Use Jan, Feb, Mar, ... Dec.',A,'[23;1H',$) GOTO 9999!8110 WRITE(*,8120)Cnull,Cesc,Cesc68120 FORMAT(A,A,'[24;1HDTC -- Invalid print choice. ',? - 'Use TT:, TERM, PRINT, or LQ',A,'[23;1H',$) GOTO 9999!8150 WRITE(*,8160)Cnull,Cesc,Cesc?8160 FORMAT(A,A,'[24;1HDTC -- Error opening output print file', - '[23;1H',$) GOTO 9999 49999 WRITE(*,9998)Cnull//Cesc//'[23;10H'//Cesc//'[K'9998 FORMAT(A,$) RETURN endwwrsor/ jy = 3 * i - 1 ! jy is y coord of cursor7 If ( jx .gt. 74) then ! For afternoon and evening' jy = jy + 1 ! appointments, put the- jx = jx - 63 ! appointments on the second End If ! line of the day* jj = j ! Now decode the time again2 call dtcat(jx,jy) ! to display. jj is time1 if (((j/2)*2) .ne. j) then ! of appointment1 jj = jj + 7 - (jj/2) ! If the time is odd then- write(iterm,16) jj ! it falls on the hour. 16 format('+' ,i2,':00') else2 jj = jj + 7 - (jj/2) ! If the time is even then1 write(iterm,17) jj ! it falls on the half hour 17 format('+',i2,':30') end if End If end do end do3 999 call dtcat(1,22) ! move cursor to the bottom$ end ! of the screen and return ww