C -h- dtcvax.for Tue Jul 8 16:01:48 1986 c------------------------------------------------------------------------ C Desk Top Calender Program C Mitch Wyle 17.11.82 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- c minder. C The program has help and menu prompting facilities for the new c user and the ability to interpret an MCR line for the experienced c user. The CRT screen functions are specific to the DEC VT-100 c screen terminal, as is the FORTRAN code. C------------------------------------------------------------------------ C Compile: C------------------------------------------------------------------------ c Declarations: include comdtc.INC C Get common file include escdtc.INC C Frequently-used escape sequences include appdtc.Inc c Initialize common declared above include dtcxidate.inc INTEGER*1 ln1 Character*1 ln1c c first character of line integer*2 ln2 integer*1 incsel(4) logical exflag C first two characters of line character*84 comlin character*9 fnamech c character*60 fnamchh c character*18 fname C Make FORTRAN OPEN happy equivalence (comlin, line(1)) equivalence (line(1),ln1) equivalence (ln1, ln2) Equivalence (ln1,ln1c) c equivalence (line(1),ln1) equivalence (fname,fnamech) c equivalence (fnamchh,fname) character*2 khomescrn,kclrscrn,kdhdw1,kdhdw2, 1 kdwide,kresetvattr,krevattr Integer*4 kincmod include stmtfuncsp.for Data comlin /' '/ Data fnamech /'DTC.DAT'/ C Make FORTRAN OPEN happy C Length of default value include comdtcd.inc include escdtcd.inc data khomescrn /'[H'/, kclrscrn /'[J'/, 1 kdhdw1 /'#3'/, kdhdw2 /'#4'/, kdwide /'#6'/, 2 kresetvattr /'[m'/, krevattr /'[7m'/ data kincmod /1/ C Default to day c End common initialization C INCMOD will flag day/week/month/year default increment... c 1=day, 2=week, 3=month,4=year Data incsel /'D', 'W', 'M', 'Y'/ C Auto display after +/- C Integer*4 lib$get_foreign C Get DCL command line, unparsed Data exflag/.false./ C True if data on DCL command line include stmtfunc.for C Get useful statement functions c Begin code: fname(18)=0 fnsz=9 comlen=0 comidx=0 homescrn=khomescrn clrscrn=kclrscrn dhdw1=kdhdw1 dhdw2=kdhdw2 dwide=kdwide resetvattr=kresetvattr revattr=krevattr incmod=kincmod c Iterm=7 c first set up default data filename Close(Unit=7) c ensure lun 7 closed in case it was pre-opened c Open new window for our operations c units seem to be PELs (we have 640 by 400 in interlace mode) open(unit=7,file='CON:0/0/639/199/Desktop Calendar - H for Help' 1 ,err=980) C >>> Assumes VT100, interactive <<< 980 continue c Escape sequences used: C 7 Save cursor and video attributes c 8 Restore ... c < Exit ATS mode c > Keypad numeric mode (Exit Alternate Keypad mode) c [?4l Reset scroll mode (jump) c [?6l Reset origin mode (absolute) c [r Set top/bottom margins (default - 1:24) c [m Graphic rendition = primary (default) c [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)) C Clean up terminal C [m Rewind iterm write (iterm,100) 1 esc,'<', esc,'>', 2 esc,'[?4l', esc,resetvattr, 4 esc,'7', esc,'[?6l', esc,'[r', esc,'8' write(iterm,100) esc,'[0;0H',esc,'[26t',esc,'[138u' c set private Amiga modes to inhibit wrap... c set so smallfont will (we hope) have all positions available. Rewind iterm 100 format ($, 21a, $) C Escape sequences ibigyr=1987 iddy=4 idmo=7 call dtcidate(idmo,iddy,ibigyr) C Get current date call dtcicomd c First time, get the MCR line, then parse and process it: c INIT exflag=.false. C Assume terminal input C istat=lib$get_foreign(comlin,,comlen) C if ((istat .ne. ss$_normal) .or. (comlen .eq. 0)) C 1 go to 77 GOTO 77 c Allow for single operation to insert an appointment in upper & lower case C if (ln1 .eq. '"') then C User quoted the line C do (i = 2, comlen) C First of many re-copy opns C line(i-1) = line(i) C copy it down C end do C comlen = comlen - 1 C end if C line(min0(comlen+1, icmln)) = 0 C Set end of line character C exflag=.true. C Flag for exit after one command c Generalized parser and scanner routine for line: 1 continue C Loop up here on any input. c initialize flags to normal search display sense (show occupied times) c and no special meeting setups... rdspfg=0 ctlfg=0 1111 continue C Re-enter here, after "+", etc comidx = 1 C Initialize for parsing if (lcalpha(ln1)) 1 ln1 = ln1 -32 C Change to upper case c Find out what's seen in the line... If ((ln1c .eq. 'D') 1 .or. (ln1c .eq. '=') 2 .or. (ln1c .eq. '*')) 3 then incmod=1 call day C (line) C display daily, go to 6 else if (ln1c .eq. 'W') 1 then incmod=2 call week C (line) C weekly, go to 6 else if (ln1c .eq. 'M') 1 then incmod=3 call month C (line) C or monthly schedules, go to 6 else if (ln1c .eq. 'Y') 1 then incmod=4 call year C (line) C or full-year calendar go to 6 c flag multiple schedule of meeting to enable multi entry else if (ln1c .eq. 'S') 1 then ln1c='D' ctlfg=1 incmod=1 call day C (line) go to 6 c use G as a schedule that will write appointments in current and c all indirected files. else if (ln1c .eq. 'G') 1 then ln1c='D' ctlfg=2 incmod=1 call day C (line) go to 6 else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) 1 then Call dtcdtinc C (line,Incmod) if (ln1 .ne. 0) go to 450 C something left, schedule it ln1c = incsel(incmod) C Phony line line(2) = 0 C End-of-line ? comlen = 1 go to 1111 C Display based on incr c reverse display flag so we hunt up free slots... note week, month c routines all get hacked on to do this... c reparse line after copying it down 1 character to remove the 'N' else if (ln1c .eq. 'N') 1 then rdspfg=1 call shrink(1, ifnb, lnb) go to 1111 else if (ln1c .eq. 'P') 1 then C Purge old appointments call strip C (line) go to 6 else if ((ln1c .eq. 'U') .or. (ln1c .eq. 'X')) 1 then call strip C (line) C Cancel or reschedule if (ln1c .gt. ' ') go to 1 C Re-scan if leftover chars go to 6 else if (ln1c .eq. 'L') 1 then c for locating free time, use week function and scan map ctlfg=1 ln1c='W' incmod=2 call week C (line) go to 6 else if (ln1c .eq. 'T') 1 then ln1c='D' incmod=1 call day C (line) C today's memos then exit go to 999 else if (ln1c .eq. 'R') 1 then ln1c='W' incmod=2 call week C (line) C remind one of this week go to 999 else if (ln1c .eq. 'C') 1 then C calendar print for month incmod=3 call month C (line) go to 999 else if (ln1c .eq. 'I') 1 then C Reset default date call dtcicomd C Process possible date string go to 6 C (for testing mods) else if ((ln1c .eq. 'H') .or. (ln1c .eq. '?')) 1 then call dhelp C HELP C (instructions) go to 6 c f filename enters new default data file name to use... else if (ln1c .eq. 'F') 1 then call shrink(1,ifnb, lnb) if (ifnb .eq. 0) 1 then fnamech = 'DTC.DAT' fnsz = 7 C Length of default value else do (i=1,lnb) fname(i)=line(i) end do fnsz=lnb end if fname(fnsz+1)=0 C Make FORTRAN OPEN happy go to 6 else if ((ln1c .eq. 'Q') .or. 1 ((line(1).eq.ichar('E').or.line(1).eq.ichar('e')).and. 2 (line(2).eq.ichar('X').or.line(2).eq.ichar('x')))) then go to 999 C Exeunt omnes else C Now get a bit fancy: (play with the line string) c if (ln1c .eq. 'E') go to 450 c If (.not. numeric(ln1)) go to 5 C unknown c 450 continue C From E above, or leftovers for +/- C The first character is a number or E, c call the daily appointment subroutine: incmod=1 line(icmln) = 0 C Tag e/o/l call day C (line) go to 6 End If c 5 continue C First character not recognized c Line was uninterpretable, so display menu: 77 call menu C Also display menu first time if no command 6 continue C get a new line and hop back up... if (exflag) go to 999 C DEBUG: Display remains of line after operations on it C C iln = 1 c C do i = 1, icmln c C if (line(i) .eq. 0) line(i) = O'32' C control Z, displays as BLOT c C if (line(i) .gt. ' ') iln = i c C end do c C WRITE(iterm,93) (line(i), i= 1, iln) c C 93 format(' ', a1, ': DTC: ',$) call dtcat(1,22) Rewind iterm write(iterm,93) 93 format(/,' DTC: ',$) Rewind iterm c --- comlin = ' ' C Initialize w/ blanks Rewind 7 read (7, 7, end=999) comlin Rewind 7 7 format(a) Do 750 n=1,80 nnn=81-n comlen=nnn if(comlin(nnn:nnn).gt.' ')goto 751 comlin(nnn:nnn)=char(0) 750 continue 751 continue c Mark only stuff read from terminal c (don't want command-input call to try to read terminal) line(min0(comlen+1, icmln)) = 0 C mark for old-style tests go to 1 999 continue C EXit, Quit, or ^Z stop end C -h- dtcdatinc.for Tue Jul 8 16:07:46 1986 Subroutine dtcdtinc C (Line,Incmod) c routine to add or subtract sidereal units (days, weeks, months or years) c incmod = 1 for day (in COMMON) c = 2 for week c = 3 for month c = 4 for year c format is c +nn or -nn : add/subtract nn default units c +/- nnu (u=d,w,m,y) to add/subt that unit c output in defdat include comdtc.INC INTEGER*1 ln1, ll Character*1 ln1c c ml is 14 long to allow refs out of bounds to l for no. days in month... C length of months - Dec, Jan ... Dec, Jan Integer*4 l(12), ml(14) equivalence (l(1), ml(2)), (line, ln1) Equivalence(ln1,ln1c) include stmtfuncsp.for include comdtcd.inc Data ml /31, 31,28,31, 30,31,30, 31,31,30, 31,30,31, 31/ include stmtfunc.for c Begin code l(2) = 28 C Initialize (may have been changed below) isign=1 C Called only if + or - is first char of LINE if (ln1c .eq. '-') 1 isign = -1 c now grab off digits... magn=0 C Initialize magnitude of value do (n = 2, icmln) ll = line(n) if (.not.( numeric(ll))) go to 5 C Exit first non-numeric magn = (magn * 10) + icvtbn1(ll) end do n = icmln C This many numeric, no overflow??? 5 continue if (magn .eq. 0) 1 magn = 1 if (alpha(ll)) 1 then ll = ll .and. ucmask c scan for d,w,m,y for units if (ll .eq. ichar('D')) 1 then incmod=1 else if (ll .eq. ichar('W')) then incmod=2 else if (ll .eq. ichar('M')) then incmod=3 else if (ll .eq. ichar('Y')) then incmod=4 else n = n - 1 C Don't strip one we didn't use: alpha end if else n = n - 1 C Don't strip one we didn't use: non-alpha end if call shrink(n, ifnb, lnb) C Shift LINE over c magn now has magnitude, isign has sign and incmod has type of increment. if (incmod .le. 2) 1 then inctyp = 1 c adjust weeks as being 7 * days and treat together if (incmod .eq. 2) 1 magn = magn * 7 else inctyp = incmod - 1 end if c inctyp is 1 for day or week, 2 for month, 3 for year if (inctyp .eq. 1) 1 then C Moving by days iddy = iddy + (isign * magn) c loop point if we move forward 100 if (iddy .gt. l(idmo)) 1 then lyd = 0 c account for leap years where february is 29 days long... if (islpyr(ibigyr) .and. (idmo .eq. 2)) 1 lyd = 1 iddy = iddy - l(idmo) - lyd idmo = idmo + 1 if (idmo .gt. 12) 1 then idmo = 1 ibigyr = ibigyr + 1 end if goto 100 end if c loop point if we move back 110 if (iddy .le. 0) 1 then c account for leap years. note ml is prev month so check def mo = 3 lyd = 0 if (islpyr(ibigyr) .and. (idmo .eq. 3)) 1 lyd = 1 iddy = iddy + ml(idmo) + lyd idmo = idmo - 1 if (idmo .le. 0) 1 then idmo = 12 ibigyr = ibigyr - 1 end if goto 110 end if else if (inctyp .eq. 2) then C moving by months idmo = idmo + (isign * magn) 200 if (idmo .gt. 12) 1 then idmo = idmo - 12 ibigyr = ibigyr + 1 goto 200 end if 300 if (idmo .le. 0) 1 then idmo = idmo + 12 ibigyr = ibigyr - 1 goto 300 end if else if (inctyp .eq. 3) then ibigyr = ibigyr + (isign * magn) end if if (inctyp .ge. 2) C months or years 1 then C Must check if we exceed month length if (islpyr(ibigyr)) 1 then l(2) = 29 else l(2) = 28 end if iddy = min0(iddy, l(idmo)) C force last day of month, if necessary end if idyr = mod(ibigyr, 100) C Restrict to current 'century' end C -h- menu.for Tue Jul 8 16:02:05 1986 c----------------------------------------------------------------------- C Menu subroutine C part of Mitch Wyle's DTC program C Inputs: c None C Output: c display screen (see below) C----------------------------------------------------------------------- c SUBROUTINE menu C Declarations: c include comdtc.INC C Need ITERM include escdtc.INC C INTEGER*1 esc /27/ c Integer*4 iterm/6/ include comdtcd.inc include escdtcd.inc C Initialize: c c iterm = 6 C Output terminal unit number c esc = O'033' c call dtcat(1,1) Rewind iterm write(iterm,1) esc,homescrn, esc,clrscrn C clear screen 1 format($,4a, $) c write(iterm,2) ' ', esc,dhdw1 C double-height 2 format($,3a,13X,'D T C C o m m a n d s') C .. c write(iterm,2) ' ', esc,dhdw2 C double-width c write(iterm,3) 3 format(/,1x, 1 8x,'D [mmddyy] - Appointment Schedule for dd mm yy',/, 2 8x,'W [mmddyy] - Week-At-A-Glance for week of dd mm yy', 3 /,8x,'M [mmyy] - Month-At-A-Glance for mm yy',/, 4 8x,'Y [yy] - Full Year calendar for yy',/, 5 8x,'+ or - nnZ - Add/Subt nn Z (Z=D,W,M,Y): change date', 5 /, 6 8x,'N(cmd str) - Reverse display sense of M or W cmd', 6 ' (free time)',/, 7 8x,'L [mm]dd[yy] n - Locate time (n * 30 mins.) free for mtg') Write(iterm,303) 303 format( 8 8x,'hh:mm>hh:mm - Add or change appointments for hh:mm',/, 9 8x,'EV (pseudo time) - Add or change EVening appointment',/, 1 8x,'P [mmddyy] - Purge appointments prior to mmddyy',/,8x, 2 'U [mmddyy] t1[>t2] - Unschedule (cancel) appointments',/, 3 8x,'X d1 t1 d2 t2 - eXchange (reschedule) appointments',/, 3 8x,' (then execute if present)', /, 4 8x,'S [mmddyy] - Schedule multiple activity on mmddyy',/, 4 8x,' (Drops notices in all indirected users files also)',/, 5 8x,'G [mmddyy] - File activities in multiple files',/, 6 8x,'F FILENAME - Change default data file to Filename',/, 7 8x,'I - Reset default date to today.',/, 8 8x,'H or ? - Help!',/, 9 8x,'Q, EX, or ^Z - Exit') C After all that Rewind iterm c return c end C -h- dtcidate.for Tue Jul 8 16:02:23 1986 subroutine dtcidate (imr, idr, iyr) C Testing aid for DTC - allows for phony value of current date to be c returned to caller, for verifying displays, etc C Calling sequence - same as Fortran IDATE c include comdtc.INC include dtcxidate.INC include defcentry.INC include escdtc.inc include comdtcd.inc include escdtcd.inc c if (xim .eq. 0) then C Assumes linker initializes to zero call date (xim, xid, xiy) if(xiy.gt.100)xiy=mod(xiy,100) xibgyr = icntry + xiy if(xibgyr.lt.100)xibgyr=xibgyr+1900 C Set long value end if imr = xim idr = xid iyr = xibgyr end subroutine dtcicomd C Process "I" command: if no arguments, reset dummy IDATE to current date, c else call dtcdatcvt to parse a date string, store those values in c XIDATE common. include comdtc.INC include dtcxidate.INC include escdtc.inc include defcentry.INC INTEGER*1 ln1 Character*1 ln1c equivalence (line(1), ln1) equivalence(ln1,ln1c) include comdtcd.inc include escdtcd.inc call shrink(1, ifnb, ilnb) C Unload command character if (ln1 .eq. 0) 1 then call date (xim, xid, xiy) if(xiy.gt.100)xiy=mod(xiy,100) xibgyr = icntry + xiy if(xibgyr.lt.100)xibgyr=xibgyr+1900 C Reset c xibgyr = icntry + xiy C Set long value ibigyr = xibgyr C Set values into common idmo = xim iddy = xid idyr = xiy else call dtcdatcvt (3) C Parse string xim = idmo C Set test values xid = iddy xiy = idyr xibgyr = ibigyr end if end C -h- dtcrdappt.for Tue Jul 8 16:02:38 1986 subroutine dtcrdappt (eofflg, indflg) c search through appointment files for entries matching range of hash values. c opens files if EOFFLG set on entry. INDFLG controls whether indirect files c should be opened as encountered, and whether caller wants to look at indirect c entry or not: c INDFLG c -1 No processing @ c 0 Normal processing c +1 Return before opening @ c EOFFLG Entry Exit c -1 Initialize EOF return c 0 Normal re-entry Normal return, 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 appt c Created 19850802, CG, using some code removed from DAY subroutine c implicit none Integer*4 eofflg, indflg C i/o, i only include comdtc.INC include apptdtc.INC include defcentry.INC C Default century for old format include escdtc.inc character*1 nullch C Old old files had trailing NULs include stmtfuncsp.for Integer*4 i, ij, lth, istrend, nunit Data nullch/0/ include comdtcd.inc include escdtcd.inc include stmtfunc.for c Begin code c *** type 950, irqhash c 950 format(2z9.8) if (eofflg .lt. 0) C Start scan 1 then nunit=1 close(1) Open (unit=nunit, file=FNc(1:fnsz), 1 status='OLD',action='READ', 1 form='FORMATTED', err=99) eofflg = 0 c *** type *, ' Opened file' end if c loop back up here to continue reading and processing input file: do while (eofflg .ge. 0) 900 format( a) C Read all 901 format(3i2, i3) C Decode old 902 format(i4, 2i2, i3) C Decode new if (eofflg .gt. 0) 1 then C must open indirect file eofflg = 0 c *** type 951, work(istart) c *** 951 format (' ', a) Do (nnn=1,80) ilst=81-nnn if(workstr(ilst:ilst).gt.' ') goto 952 c find index of end string (last nonspace char) End Do 952 continue nunit = 2 close(2) Open (unit=nunit, file=workstr(istart:ilst), status='old', 1 form='formatted', action='READ', 2 err=1067) end if read (nunit, 900, end=400,err=400) workstr c find lth now by hand c assume 80 char work array max do 705 i705=1,80 lth=81-i705 if(workstr(lth:lth) .gt. ' ') goto 706 workstr(lth:lth)=nullch 705 continue 706 continue c *** type *, ' ', workstr C Look for non-blank C & non-null do (i = min0(lth, iwrkln), 1, -1) if ((workstr(i:i) .ne. ' ') 1 .and. (workstr(i:i) .ne. nullch)) 2 go to 10 C Break end do i = 1 C All blank entry ??? 10 lth = i c String is filled with blanks regardless of length of record if (chnumeric(workstr(10:10))) 1 then C new format read(workstr, 902, err=30) ihy, ihm, ihd, iht istart = 12 C Index of first valid character c *** type *, ' New format' else C Old format 30 continue C Retry old read(workstr, 901, err=300) ihy, ihm, ihd, iht ihy = ihy + icntry C Insert current century istart = 10 C Assume old, old format c *** type *, ' Old format' end if C (workstr(10) is numeric) if (workstr(istart:istart) .eq. ' ') 1 istart = istart + 1 C Index of first valid character iwkln = max0((lth - istart) + 1, 1) istrend = (istart + iwkln) - 1 iaptln = max0(min0(iwkln, icmln), 1) if (ihm .eq. 99) 1 then ihy = 9999 C set all fields ihd = 99 iht = 999 if ((indflg .ge. 0) .and. (nunit .eq. 1)) 1 then call fnscan(work(istart), icmln - istart + 1, 1 iwkln, ij) C Common code to check filename if (ij .ne. 0) 1 then C Skip if no file c *** type *, ' IJ = ', ij eofflg = 1 if (indflg .gt. 0) 1 then apptstr = workstr(istart:istrend) return C DAY, STRIP want a look end if C Found 1 end if C non-null file-name end if C valid place for indirect else C not filename flag in record irchash = ihymd(ihy, ihm, ihd) C Compute hash for record c *** type 950, irchash if ((irchash .ge. irqhash(1)) 1 .and. (irchash .le. irqhash(2))) 2 then C Found record within range, exit apptstr = workstr(istart:istrend) c *** type *, ' Returning' return C Break out of loop 400 continue C no more appointments left in file. c *** type *, ' EOF' if (nunit .eq. 1) 1 then C Which file were we reading? eofflg = -1 C real end of file else 1067 close (2) C Error opening indirect file nunit=1 end if C Which unit had EOF end if C Hash range test end if C type of record 300 continue C Error decoding y/m/d/t fields end do C Read next line from current file close (1) C Close first-level 99 continue C Failed first open end C -h- dtcmthnam.for Tue Jul 8 16:03:02 1986 SUBROUTINE dtcmthnam (im,monthn) c----------------------------------------------------------------------- C Subroutine dtcmthnam (formerly GABY) C Part of Mitch Wyle's DTC program C return a string corresponding to the month number c Month number contained in IM. Send back string in MONTHN. c (JANUARY for 1, etc.) C----------------------------------------------------------------------- C Modified 850315 - Center month names in table, use mixed case - CG c Modified 850802 - Renamed DTCMTHNAM C Declarations: c INTEGER*1 monthn(9) c *** character*9 monthn C Can't use, char params expect descriptor C Table of month names and numbers (centered, even lengths biased left): c INTEGER*1 months(9,14) character*9 monthch(14) equivalence (months, monthch) C Select the right month and fill monthn with it: Data monthch/ 'December ', 1 ' January ', 'February ', ' March ', ' April ', 2 ' May ', ' June ', ' July ', ' August ', 3 'September', ' October ', 'November ', 'December ', 4 ' January '/ c C ALLOW FOR OVERFLOWS... IMM=IM+1 c *** monthn = monthch(imm) C String assignment c Do (i=1,9) C byte-at-a-time Monthn(i) = months(i,imm) end do c All done. end C -h- dtcalcdow.for Tue Jul 8 16:03:26 1986 SUBROUTINE dtcalcdow(ib,il,im,iyx) c----------------------------------------------------------------------- C DTCALCDOW subroutine C part of Mitch Wyle's DTC program C Inputs: c im - month (number 1-12) c iy - year (number 0-9999) 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 days C 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). c Modified 850724 by Glenn Everhart to work for years between 1900 c and 1982 (formerly thought all intervening years started c on Friday) c Modified 850726 by CG to simplify days-since-base calculation. c NOTE: Has been reworked to calculate all dates AS IF c the Gregorian Calendar had been in effect since AD 1, c and that the Gregorian correction for 100 and 400 c will be valid indefinitely (the 1928 Episcopal c Book of Common Prayer indicates this is valid at least c until AD (or CE) 8400, but I don't think I, or anybody c 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 be c valid since there was no year zero. If any calendar phreak c wants to figure it out for the Julian calendar, have fun, c just keep in mind that the Gregorian superseded the Julian c at different times and in different ways in different localities c (October 4, 1582 was followed by October 15 in Catholic c countries, and another "long sleep" occurred in September 1752 c in English-speaking realms, but apparently in Sweden c 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 Frederic c of Pirates of Penzance with little to complain about) C Russia, Romania, Greece and Turkey did not convert until c the twentieth century. C P.S.: 4th parameter (input year) is no longer modified. C Modified 850729 by CG - Get rid of loop that added number of days of c each month --- why sum a sequence of constants? c Modified 850802 by CG - renamed from DANY to DTCALCDOW, removed c default century and previously commented-out code c Modified 850809 by CG - Insure IB output in range 1..7: negative values c (from negative year input) caused DTCDSPMTH to zap its c character arrays and display some verrry strange-looking months C----------------------------------------------------------------------- c c Declarations: c Base value for IDAYS, day-of-week for January 1, AD 1 C parameter (idow = 2) Integer*4 im C Julian Month Integer*4 iyx, iy C Julian Year Integer*4 lpyear C Define additive variable include stmtfuncsp.for c Array of months and number days Integer*4 months(12) C in each one c array of months containing d/o/w Integer*4 bomdow(12) C of first day of month Data months 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ C in each one c array of months containing d/o/w data bomdow 1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 / C of first day of month include stmtfunc.for C Need ISLPYR function c c Begin code c iy = iyx C Copy parameter c Take care of leap years: lpyear = 0 C Assume "common" year if (islpyr(iy)) 1 then months(2) = 29 C length of February in leap year if (im .gt. 2) lpyear = 1 C Add one to BOM DOW after Feb else months(2) = 28 C .. "common" year end if c Rather than add up all of the days since January First, AD 1 c (which would have been a Monday had the Gregorian calendar been in effect then), c we note that the day of week of 1 January advances by 1 day per year, c plus another day the year AFTER a leap year, etc, therefore just add c values of years, leap years, century years, etc, modulo 7, to figure out c day of week of the month we are interested in. itemp = iy - 1 C not including current year C Day of week of 1/1/0001 C plus number of years C plus number of leap years C less even hundreds C but add back even four hundreds C plus day of week for BOM idays = idow 1 + itemp 2 + (itemp/4) 3 - (itemp/100) 4 + (itemp/400) 5 + bomdow(im) 6 + lpyear C plus 1 for March or later in leap year ib = mod ( idays , 7 ) C Find day of week 0:6 if (ib .le. 0) ib = ib + 7 C In case IY was negative (Sun is day 1) il = months(im) C Length of the current month end C -h- dtcdspmth.for Tue Jul 8 16:03:45 1986 SUBROUTINE dtcdspmth (ib,il,xoff,xspa,YOFF,yspa) c----------------------------------------------------------------------- C DTCDSPMTH month printing subroutine (formerly MISCHY) C part of Mitch Wyle's DTC program C Inputs: c ib - begining day of the week c il - length of month in days c xoff - offset for x coordinate c xspa - number of spaces to skip between numbers c yoff - offset for y coordinate c yspa - number of lines to skip between lines C Output: c display screen (see below) C Modified 850301, CG - write full line at a time, rather that each date c Modified 850802, CG - Renamed from mischy C----------------------------------------------------------------------- c c Declarations: Integer*4 ib C beginning day of the week Integer*4 il C length of month in days Integer*4 xoff C x offset Integer*4 xspa C number of spaces between numbers Integer*4 yoff C y offset Integer*4 yspa C number of lines to skip between lines include comdtc.INC C Need ITERM include escdtc.INC Integer*4 ix C x coordinate of where to put day Integer*4 iy C y coordinate of where to put day Integer*4 ip C the day of the week for date in hand Integer*4 ixo C xoff + 1 c numbers as characters Integer*2 nums(31) Integer*2 wknums(7) c 1 format('+',6(a2,x),a2) Character*1 nmfmt(18) Character*2 nmff Character*18 nmfm Equivalence(nmfm,nmfmt(1)),(nmfmt(10),nmff) Data nmfm/'($,6(1A2,01X),1a2)'/ Data nums 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', 4 '30', '31'/ include comdtcd.inc include escdtcd.inc C To contain copies of above, or blanks c Begin code do (i = 1, 7) C One week's worth wknums (i) = ' ' C initialize end do ip = ib ix = xspa + 1 C Used in format # 1 ixo = xoff + 1 iy = 4 + YOFF c Now write month out to screen, one week at a time: Do (i = 1, il) wknums(ip) = nums(i) C Get day as character If ( ip .eq. 7 ) C is it Saturday again? 1 then call dtcat(ixo,iy) C Position cursor for line write(nmff,110)ix Rewind iterm write(iterm,nmfm)wknums Rewind iterm c write (iterm,1) wknums C Write filled array ip = 1 C reset day to Sunday. iy = iy + 1 + yspa C move down one line else ip = ip + 1 C increment day number End If end do if (ip .ne. 1) C Partial buffer remains 1 then call dtcat(ixo,iy) C Position cursor Rewind iterm c write (iterm,1) (wknums(i), i = 1, ip - 1) write(nmff,110)ix 110 format(i2.2) write(iterm,nmfm)(wknums(i),i=1,ip-1) 1 format($,a2,1x,$) Write(iterm,223) 223 format(/,1x) Rewind iterm c emit trailing crlf... cC Write rest of array end if c 1 format('+',6(a2,x),a2) end C -h- dhelpvax.for Tue Jul 8 16:04:30 1986 c----------------------------------------------------------------------- C Help subroutine C part of Mitch Wyle's DTC program C Inputs: c None C Output: c display screen (see below) C----------------------------------------------------------------------- c SUBROUTINE dhelp include comdtc.INC include escdtc.INC c c Integer*4 iterm/6/ c INTEGER*1 esc/O'033'/ INTEGER*1 buf(79) include comdtcd.inc include escdtcd.inc C Initialize: c c iterm = 6 C Output terminal unit number c esc = o'033' call dtcat(1,1) Rewind iterm write(iterm,91) esc,homescrn, esc,clrscrn C clear screen write(iterm,1) ' ', ' D T C - Desk Top Calendar' c write(iterm,1) ' ', esc,dhdw2, ' D T C - Desk Top Calendar' c 1 format(40a) 91 format($,4a, $) Open (unit=1,file='DTC.HLP',action='READ',form='FORMATTED', 1 status='OLD', err=9) Do (i=1, 22) Read(1,4,end=5) buf do 301 n=1,78 ibln=79-n if(buf(ibln).gt.32)goto 302 buf(ibln)=0 301 continue 302 continue if (ibln .ne. 0) then write (iterm,6) (buf(j), j=1,ibln) else write (iterm,6) end if end do c 4 format(100a1) 6 format(1x,100a1) c 5 close(unit=1) C Read end-of-file Rewind iterm return c 9 write(iterm, 99) 99 format(' Help file C:DTC.HLP not found') Rewind iterm Return end C -h- day.for Tue Jul 8 16:04:45 1986 c----------------------------------------------------------------------- C Daily Appointment subroutine C part of Mitch Wyle's DTC program C Input: c line - 72 INTEGER*1s; Format: D [mmddyy [hh:mm>HH:MM [appointment]]] C Output: c display screen (see below) C----------------------------------------------------------------------- C Modified 850314, CG, to write day-of-week to daily-appointment screen, c and note current time if current day displayed (reverse video) c Modified 19850802, CG, to write full date as well, and handle both new- c and old-format appointment files. c Modified 851218, CG: change default range of appointment from whole day c to 8:00 only C Modified 860220, CG: Check for duplicate appointment times, c move and flag them SUBROUTINE day C (line) c Declarations: include comdtc.INC include apptdtc.INC include escdtc.INC character*100 apstr INTEGER*1 appnt(icmln) C appointment string INTEGER*1 temp(2), ll, ln1, ap1 Character*1 ln1c C temporary string converting array INTEGER*1 blot C ^Z, for entry from display Integer*4 id, idr C Julian Day Integer*4 im, imr C Julian Month Integer*4 iye, iyr C Julian Year Integer*4 idx, imx, iyx, isx C copies for calling DANY integer*1 ibsp Integer*4 eofflg C uses A6 fmt C 'day' is in format real*8 daylist(7) character*9 mthlist(12) character*22 dupl C only 3:22 used INTEGER*1 dupb(22) Integer*4 iscnds equivalence (line, ln1), (apstr, appnt),(apstr, ap1), 1 (dupl, dupb) character*1 blotc equivalence(blot,blotc) Equivalence (ln1,ln1c) include stmtfuncsp.for data blotc/'_'/ include comdtcd.inc include escdtcd.inc Data daylist / ' Sun', ' Mon', ' Tues', 1 'Wednes', ' Thurs', ' Fri', ' Satur' / Data mthlist 1 /' January', ' February', ' March', ' April', 2 ' May', ' June', ' July', ' August', 3 'September', ' October', ' November', ' December'/ include stmtfunc.for c Initialize: dupl = '##' C Init for duplicate check c leave = or * if ((ln1 .and. ucmask) .eq. ichar('D')) 1 call shrink(1, ifnb, lnb) call dtcdatcvt(3) C Pick off a date value im=idmo id=iddy iye=ibigyr call dtcalcdow (isx, imx, im, iye) C Get day-of-week for B/O/M idx = mod (id + isx - 2, 7) + 1 C Calc current d/o/w call dtcidate(imr, idr, iyr) C Get today's date C if current = today, C flag current time if ((im .eq. imr) .and. 1 (id .eq. idr) .and. 2 (iye .eq. iyr)) then C Displaying current day Call time(iscnds) scnds=iscnds scnds = amax1(scnds, 28801.) C Get current time (>8 AM) ihalf = mod(ifix(scnds/1800.), 48) C current half-hour (orig 0) ihour = ihalf/2 C Current hour ihalf = ihalf - (ihour*2) C 0 or 1 for half-hour else ihour = 0 C Set non-match value endif c ************************** Move the cursor to top of screen and clear it, c ************************** set up appointments display: Rewind iterm write(iterm,4) esc,homescrn, esc,clrscrn 4 format($, 4a, $) write(iterm,5,err=598) 1 daylist(idx), mthlist(im), id, ibigyr 5 format(1x,'Schedule - ', a6,'day, ', a9, i3, ',', i5) c write(iterm,5) ' ', esc,dhdw2, c 1 daylist(idx), mthlist(im), id, ibigyr 598 continue Do (i=8,16) If ( i .gt. 12 ) then j = i - 12 Else j = i End If if (i .ne. ihour) then C Check for highlighting write(iterm,6) j write(iterm,7) j else C must be current hour if (ihalf .eq. 0) then C Check which half write(iterm,96) esc,revattr, j, esc,resetvattr write(iterm,7) j else write(iterm,6) j write(iterm,97) esc,revattr, j, esc,resetvattr endif endif end do 6 format(1x,i2,':00 -') 7 format(1x,i2,':30 -') 96 format (2x, 2a, i2,':00', 2a, ' -') 97 format (2x, 2a, i2,':30', 2a, ' -') if (ihour .ge. 17) then C Highlight 'Evening' line write(iterm,98) esc,revattr, esc,resetvattr else C Includes display other than today write(iterm,9) end if 9 format(1x, 'Evening -', /, x, 75('=')) 98 format(1x, 2a, ' Evening', 2a, ' -', /, x, 75('=')) c ******************* Screen has now been displayed, c ******************* now check rest of line for time and appointment if (ln1 .ne. 0) then C More characters available? iht = 80 C Default is 8:00 ihmx = iht C (only 1 entry) call dtctimcvt(iht, ihmx) C Decode time value if present ihh1 = (iht+2)/5 C Adds 1 if trailing 3 ihh2 = (ihmx+2)/5 C Result is 16 to 35 idmx = min0(max0(ihh2-ihh1, 1), 20) C 8:00>6:00 iht = min0(iht,173) C Limit entry time (DTCTIMCVT lim is 180) c Note: range of h1:00>h1:30 is considered only one scheduling interval, c 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 C Clear appointment string do (i = 1, icmln) ll = line(i) appnt(i) = ll if (ll .eq. 0) go to 6789 C done ivx = i C Save current length end do c Was there an appointment string input? c If so, put it in file, and display it on screen. c If not, move cursor to correct time on screen, c then input the appointment, put in file and re-display it. 6789 If (ap1 .eq. 0) then C Empty appointment string iy = ihh1 - 13 C Vertical position for half hour c amiga fixup ... iy is 1 less iy = iy-1 c end amiga fixup... ix = 11 call dtcat(ix,iy) ibsp=8 write(iterm, 987) blot,ibsp C write blot, backspace 987 format ($, 2a1, $) Rewind iterm Rewind 7 read(7,13,END=914,err=914) workstr Rewind 7 13 format(a) do 305 nnn=1,80 lapp=81-nnn if(workstr(lapp:lapp).gt.char(32))goto 306 workstr(laPP:LAPP)=char(0) 305 continue 306 continue c copy appointment for use later... ifnb = 0 lnb = 0 ivx = 0 Do (i = 1, lapp) ll = work(i) C fetch character if (ll .gt. 32) then if (ifnb .eq. 0) ifnb = i C Flag first non-blank lnb = i C Flag last non-blank end if if (ifnb .ne. 0) then C Copy after first n/b ivx = ivx + 1 appnt(ivx) = ll end if end do if (ifnb .eq. 0) go to 914 C Nothing on read either End If ivx = min0(ivx, iaptlim) C ivx = length of string C If we are using the 'S' command, add meetings to the indirected files ONLY, C not to the current (control) file. if (ctlfg .ne. 1) then C Add appointment if D or G close (1) C Insurance Open ( unit=1,file=FNc(1:fnsz) 1 ,status='UNKNOWN',form='FORMATTED', 1 position='append',err=9876) ihtxx=iht do (ixx = 1, idmx) write(1,14,err=597) iye,im,id,ihtxx,apstr(1:ivx) 597 Continue if ((ihtxx/10)*10 .eq. ihtxx) 1 then ihtxx=ihtxx+3 C IHT is even hour, go to next half hour else ihtxx=ihtxx+7 C 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 C Empty line (no appointment to add) 914 idmx = 0 C Use as flag for display only end if eofflg = -1 C Request OPEN prveof = 0 C Set for DO WHILE lookind = 0 if (ctlfg .ne. 0) lookind = 1 C Set for looking at filenames irqhash(1) = ihymd(iye, im, id) C Set match for file scan irqhash(2) = irqhash(1) C One day only IHTsav=IHT c Iht clobbered by dtcrdappt do while (prveof .ge. 0) call dtcrdappt(eofflg, lookind) if (eofflg .eq. 1) 1 then C Returned with filename string c on scheduling multiple dates via S or G functions, use this occasion to c add the record to everyone's calendar file. close(2) Do (nnn=1,90) nnm=101-nnn If(Workstr(nnm:nnm).ge.char(32))Goto 963 c find last nonblank char in string End Do 963 Continue Open (unit=2, file=workstr(istart:nnm), status='UNKNOWN', 1 form='FORMATTED', 2 position='APPEND', err=1119) c ihtxx=iht ihtxx=ihtsav do (ixx = 1, idmx) write(2,14,err=596)iye,im,id,ihtxx,apstr(1:ivx) 596 Continue if ((ihtxx/10)*10 .eq. ihtxx) then ihtxx=ihtxx+3 C iht is an even hour ... add the half hour else ihtxx=ihtxx+7 C iht is a half hour ... make up to next hour end if end do 1119 close(2) c Display appointment if it matches current date else If (eofflg .eq. 0) 1 then iy = min0(max0((((iht+2) / 5) - 13), 3), 22) c Amiga fixup -- iy is 1 less iy=iy-1 c end Amiga fixup C Compute vertical posn C Have we been here before if (dupb(iy) .eq. 32) 1 then C No dupb(iy) = '-' C Flag it else C Duplicate time stamps, find substitute do (ix = iy-1, 3, -1) C Search backward first if (dupb(ix) .eq. 32) 1 then iy = ix C Save replacement dupb(iy) = 'v' C Point to where it should go go to 3141 C >>> BREAK <<< end if end do do (ix = iy + 1, 22) C Search forward if (dupb(ix) .eq. 32) 1 then iy = ix C Save replacement dupb(iy) = '^' C Point to where it should go go to 3141 C >>> BREAK <<< end if end do dupb(iy) = blot C Flag it end if 3141 ix = 2 C first char to print if (appoin(1) .ne. 32) 1 then ix = 1 C '12:00 - Appointment' else if (iaptln .le. 1) 1 then appoin(2) = blot C Display BLOT for empty entry iaptln = 2 end if end if kk = min0(iaptln, iaptlim) call dtcat(8,iy) C Set cursor position C flag + text write(iterm,300) dupb(iy), ' ', apptstr(ix:kk), 1 esc,'[K' C Erase EOL 300 format($, 5a, $) End If C eofflg .ge. 0 prveof = eofflg C Show what happened end do C while (prveof) write(iterm,367) 367 format(' ') d write(4,4203) d4203 format(' Day .. returning') d call dely call dtcat(1,22) Return end C -h- month.for Tue Jul 8 16:05:05 1986 c----------------------------------------------------------------------- C Month-at-a-glance subroutine C part of Mitch Wyle's DTC program C Input: c line - 72 INTEGER*1 string; Format: M [dd[19[yy]]] C Output: c display screen (see below) C Line c 1 Prevmonth Nextmonth c 2 SMTWTFS SMTWTFS C 3-8 Calendar Calendar c 9/10 Y e a r M o n t h Y e a r c 11 S M T W T F S c 13-23 C a l e n d a r C Lines 9/10 are double-height/double-width c Odd lines 11-23 are double-width c Even lines 10-22 are blank C----------------------------------------------------------------------- C Modified 850318, several changes- CG c Display today's date in current, prev or next month c in reverse video c Write out >>> only <<< non-blank flags (*'s) c Speed-up of month display (actually in dtcdspmth subr) c Months mixed-case and centered (GABY) c Modified 850809 - display IBIGYR both sides of month, DH/DW SUBROUTINE month C (line) c Declarations: include comdtc.INC include apptdtc.INC include escdtc.INC INTEGER*1 TEMP Dimension TEMP(4) C temporary string converting array CHARACTER*4 TMPP EQUIVALENCE(TMPP,TEMP(1)) Integer*4 id C Julian Day Integer*4 im C Julian Month Integer*4 iy C Julian Year Integer*4 prveof, eofflg c string month name INTEGER*1 monthn(9), 1 lmonth(9) c Entries true if lenght of name is even logical*1 lmneven(12) c Entries true if length of name is odd logical*1 lmnodd(12) INTEGER*1 out(79) C The output string and * array INTEGER*1 rchr C Flag set (or reset) character INTEGER*1 ln1 C Same as line(1) include stmtfuncsp.for equivalence (line, ln1) Character*41 lxfmt Character*2 lxfixx,lxfixy Character*1 lxfc(41) Equivalence(lxfc(1),lxfmt) Equivalence (lxfixx,lxfc(14)),(lxfixy,lxfc(27)) include comdtcd.inc include escdtcd.inc c 8 format(3a, 4(a1, x), x, 9(x,a1), x, 4(x, a1), $) c write(iterm,8) ' ', esc,dhdw2, temp, monthn, temp c data lxfmt/'(7x,4(a1,2x),01x,9(2x,a1),01x,4(2x,a1),$)'/ data lmneven/ 1 .false., .true., .false., .false., .false., .true., 2 .true., .true., .false., .false., .true., .true./ c Entries true if length of name is odd data lmnodd 1 /.true., .false., .true., .true., .true., .false., 2 .false., .false., .true., .true., .false., .false./ include stmtfunc.for c Trim off the M from command line: if(ln1.gt.96)ln1=ln1-32 if ((ln1 ) .eq. Ichar('M')) 1 call shrink(1, ifnb, lnb) call dtcdatcvt(2) C Decode date string im=idmo C Pick up result from common id=iddy iy=ibigyr call dtcidate(irm,ird,iry) C Real month,day,year, for display highlight c Move the cursor to the top part, clear the screen write(iterm,600) esc,homescrn, esc,clrscrn 600 format ($, 4a, $) Call Dtcat(1,1) c Now start building the output string: (out) WRITE(TMPP,20,ERR=11)IY C encode(4, 20, temp, err=11) iy 11 continue 20 format(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 else If ( im .eq. 12 ) then nm = 1 ny = iy + 1 End If C 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 = 3 if (lmneven(lm)) ix = ix + 1 call dtcat(ix, 1) write(iterm,6) lmonth ix = 61 if (lmneven(nm)) ix = ix + 1 call dtcat(ix, 1) write(iterm,6) monthn 6 format ($, 9(1a1, 1x)) call dtcat(1, 2) write(iterm,7) 7 format($,'Su Mo Tu We Th Fr Sa', 1 T60,'Su Mo Tu We Th Fr Sa') c call dtcat(35, 7) C Center year above cur month c write(iterm,96) temp c 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) If ((irm .eq. lm) .and. (iry .eq. ly)) then C today in rev video irdw = mod (ird + ib - 2, 7) C Day of week (orig 0) irwk = (ird + ib - 2)/7 C Week in month (orig 0) call dtcat ((irdw*3) + 2, irwk + 3) 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) If ((irm .eq. nm) .and. (iry .eq. ny)) then C today in rev video irdw = mod (ird + ib - 2, 7) C Day of week (orig 0) irwk = (ird +ib - 2)/7 C Week in month (orig 0) c added 1 to x coord in dtcat for amiga fixup here and just above. call dtcat ((irdw*3) + 60, irwk + 3) write (iterm,684) esc,revattr, ird, esc,resetvattr end if c 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 + 1 ixx = ix - 9 ixy = 14 - ix ixx2=ixx+ixx ixy2=ixy+ixy c double spaces for single-wide char screen to emulate dbl wide char screen write(lxfixx,2220)ixx2 2220 format(i2.2) write(lxfixy,2220)ixy2 write(iterm,lxfmt)temp,monthn,temp c write(iterm,225)temp c 8 format(3a, 4(a1, x), x, 9(x,a1), x, 4(x, a1), $) c write(iterm,8) ' ', esc,dhdw2, temp, monthn, temp c Now print the week day headers for this month, and the days for this month: call dtcat(1,11) write(iterm,10) 10 format($, 1 ' S u n M o n T u e s W e d s T h u r s', 1 ' F r i S a t') c x x x x x x x x C Mark double-width lines c write (iterm,138) c 1 esc,'[13H', esc,dwide, c 2 esc,'[15H', esc,dwide, c 3 esc,'[17H', esc,dwide, c 4 esc,'[19H', esc,dwide, c 5 esc,'[21H', esc,dwide, c 6 esc,'[23H', esc,dwide 138 format ($, 24a, $) c call dtcalcdow(ib,il,im,iy) call dtcdspmth(ib,il,8,8,9,1) C For single-width c call dtcdspmth(ib,il,1,3,9,1) C For double-width c If ((irm .eq. im) .and. (iry .eq. iy)) then C today in rev video c irdw = mod (ird + ib - 2, 7) C Day of week (orig 0) irwk = (ird + ib - 2)/7 C Week in month (orig 0) call dtcat ((irdw*11)+9, (irwk*2)+13) if (id .eq. ird) then write (iterm,684) esc,'[4;7m', ird, esc,resetvattr else write (iterm,684) esc,revattr, ird, esc,resetvattr go to 685 C And show looking-at date end if 684 format($, 2a, i2, 2a, $) else 685 irdw = mod (id + ib - 2, 7) C Day of week (orig 0) irwk = (id + ib - 2)/7 C Week in month (orig 0) call dtcat ((irdw*11)+9, (irwk*2)+13) write (iterm,684) esc,'[4m', id, esc,resetvattr end if if (rdspfg .eq. 0) then rchr='*' out(1) = ' ' else rchr=' ' out(1) = '*' end if Do (i= 2, 31) C set the out array to all blanks: out(i) = out(1) end do c Now for files I/O to put *'s on days with appointments: irqhash(1) = ihymd(iy, im, 1) C Want entries for irqhash(2) = ihymd(iy, im, 31) C current month eofflg = -1 prveof = 0 do while (prveof .ge. 0) call dtcrdappt(eofflg, 0) if (eofflg .ge. 0) out(ihd) = rchr prveof = eofflg end do c 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 C increment day number If ( ip .gt. 7 ) then C is it Sunday again? ip = 1 C reset day to Sunday. iy = iy + 2 C move down one line End If if (out(i) .ne. 32) then C Write only non-blank entries C ix = 11 * ip - 4 c ix = 6 * ip - 5 call dtcat(ix,iy) C position cursor write(iterm,231) out(i) C write * to screen 231 format($,a1, $) end if end do C # days in month 999 call dtcat(1,23) C Position for next prompt end C -h- fnscan.for Tue Jul 8 16:05:30 1986 c subroutine FNSCAN - scan file-name record (999999999x=) c and strip space, mark 0 at end of name subroutine fnscan(work, maxlen, iwkln, ijr) INTEGER*1 work(maxlen) INTEGER*1 ll ij = 0 C Initialize output index do (ii=1, min0(iwkln, maxlen)) C Start loop ll = work(ii) C Get input character if (ll .gt. 32) then C Strip all spaces & ctls if (ll .eq. ichar('=')) go to 10 C '=' marks end ij = ij + 1 C Character accepted work(ij) = ll C Copy it end if C (graphic character) end do C Loop 10 work(min0(ij+1,maxlen)) = 0 C Set marker for OPEN ijr = ij C Return length of string end C -h- week.for Tue Jul 8 16:05:58 1986 c----------------------------------------------------------------------- C Week-at-a-glance subroutine C part of Mitch Wyle's DTC program C Input: c line - 72 INTEGER*1 string; Format: W [mmddyy] C Output: c display screen (see below) C----------------------------------------------------------------------- C Modified 850117 to fix leap-year problems - CG c Modified 850314 to use real corners, lines and T's for box - CG 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 code c SUBROUTINE week C (line) C Declarations: c include comdtc.INC include apptdtc.INC include escdtc.INC c INTEGER*1 ln1, ll C equiv to input line INTEGER*1 temp(2) C temporary string converting array logical apts(7,19), aptsln(133), tflg Integer*4 prveof, eofflg Integer*4 HASH Integer*4 id C Julian Day Integer*4 im C Julian Month Integer*4 iy, iyd C Julian Year c lengths of months ... leap years adjusted in code c December Jan ... Dec Jan Integer*4 ml(14) include stmtfuncsp.for equivalence (line, ln1), (apts, aptsln) include comdtcd.inc include escdtcd.inc Data ml 1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/ include stmtfunc.for c Initialize: iss = z'7FFFFFFF' C Impossible saved Sunday day... iwf=0 C Adjustment factor if ((ln1 .and. ucmask) .eq. Ichar('W')) 1 call shrink(1, ifnb, lnb) call dtcidate(imx,idx,iyx) C initialize to today's date call dtcdatcvt(3) C Get date string im=idmo C Copy values id=iddy iy=ibigyr if (islpyr(iy)) then ml(3)=29 C Feb is in ML(3), not ML(2) C else ml(3)=28 C C Garman, 17-Jan-1985 end if C Where we look for free space of n units or more length, C then just display reverse and zot out all shorter periods if (ctlfg .eq. 1) rdspfg=1 tflg = (rdspfg .ne. 0) C initialize flag do (ij = 1, 7*19) aptsln(ij) = tflg end do if (ctlfg .ne. 0) then C Locate N intsz = 0 i = 1 do while(numeric(line(i))) intsz = (intsz * 10) + icvtbn1(line(i)) i = i + 1 if (i .gt. icmln) go to 1191 end do c clamp interval size to permissible range... 1191 intsz = min0(max0(intsz, 1), 18) end if C Paint the screen: c c following sequence moves to upper left corner on VT100 compatible terminals c and clears screen write(iterm,6) esc,homescrn, esc,clrscrn 6 format(1x,4a,$) call dtcat(1,1) c Now write box, in graphics mode, to enclose days of week write (iterm, 70) '+', '+' C Upper corners & top line c irow=2 Do (i = 1, 6) C 6 more days' worth Call DtcAt(1,irow) irow=irow+1 write (iterm, 71) Call DtcAt(1,irow) irow=irow+1 write (iterm, 71) Call DtcAt(1,irow) irow=irow+1 write (iterm, 72) end do c Call DtcAt(1,irow) irow=irow+1 write (iterm, 71) Call DtcAt(1,irow) irow=irow+1 write (iterm, 71) C two more sides Call DtcAt(1,irow) irow=irow+1 write (iterm, 73) '+', '+' C Lower corners & bottom line c 70 format (x, 1a1, 74('-'), 1a1) C Upper/lower corners C sides 71 format (x, '|', 74(' '), '|') 72 format (x, '+', 74('-'), '+') C interior lines 73 format (x, 1a1, 74('-'), 1a1) C Upper/lower corne1rs 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) write(iterm,10) ' Friday' call dtcat(2,20) write(iterm,10) ' Saturday' C Now figure out which Sunday is closest to the day specified by id: c call dtcalcdow(ib,il,im,iy) C Remember: ib = 1st day of month c il = length of month c ib = day number of 1st day of month, 1=sunday. if ( ib .eq. 1 ) then is = 1 C IS is the Sunday we want. It is else C either the 1st day of the month is = 9 - ib C or 9 - 1st day of month. end if C Now...Sunday may be in preceding month 11 continue C 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) then is=is-7+ml(im) im=im-1 if (im .le. 0) then c 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 C of the month, then keep adding is = is + 7 C 7 until we get to the week we go to 11 C want. end if 301 continue c since we can wrap months down as well as up construct date limits here... c *** if (iy .gt. 1900) iy=iy-1900 c just generate a hashcode that is strictly increasing as a function of c date. only purpose is to be monotonic increasing, so continuity is c not important. we use other methods to handle exact offsets. note that c where wrap arounds occur, iss is allowed to be a little larger than c real month length or a small negative where used below...not here. irqhash(1) = ihymd(iy, im, is) iss = is C don't lose track of Sunday's date. issss = is C It will be important later... C Now figure out where to write the dates of the days of the week, c and write em out where they belong: c iyd = mod(iy, 100) C Display two digits Do (i=1,7) jy = 3 * i call dtcat(2,jy) if ((im .eq. imx) .and. (iy .eq. iyx)) then if (is .eq. idx) then if (id .eq. idx) then C reverse + underline write(iterm,130,err=99) 1 esc,'[4;7m', im,is,iyd, esc,resetvattr else C reverse only write(iterm,130,err=99) 1 esc,revattr, im,is,iyd, esc,resetvattr end if else go to 684 end if else 684 if (is .eq. id) then C underline only write(iterm,130,err=99) 1 esc,'[4m', im,is,iyd, esc,resetvattr else C N/O/T/A, nothing fancy write(iterm,13,err=99) im,is,iyd end if end if 99 is = is + 1 If ( is .gt. il ) then C Did the month change is = 1 C during this week? im = im + 1 If ( im .gt. 12 ) then C Did the year change im = 1 C during this week? iy = iy + 1 iyd = mod(iy, 100) End If End If irqhash(2) = ihymd(iy, im, is) C save last day value in hash end do 13 format($, i3, '/', i2.2,'/',i2.2) 130 format($, a1, a, i3, '/', i2.2,'/',i2.2, a1, a) C Now for Files I/O: c c Set up a boolean array of appointment times and days of c the week. Notice that if this program were written in c assembler, we would use only 18 INTEGER*1s and store this c information by bits instead of INTEGER*1s. Oh well. There c goes 100 INTEGER*1s of storage space... c When life confronts you with its troubles and woes, c Have no fear, just fire photon torpedos C C Read the appointments; If the appointment is for one of c the days in this week, mark that spot in the appointments c array true. Otherwise that coordinate is false. The array c looks like this: C Su Mo Tu We Th Fr Sa C 8:00 T F F F F F F C Appointment on Su at 8:00 c 8:30 F T T T F F F C Appointments on Mo, Tu, We at 8:30 c 9:00 F F F F F F F C No appointments at 9:00 this week c 9:30 C . . . . . . . . c . . . . . . . . etcetera c . . . . . . . . c C sic itur ad astra C Etcetra. Caveat emptor and three other latin words. C prveof = 0 eofflg = -1 do while (prveof .ge. 0) call dtcrdappt(eofflg, 0) C Look at appointments file if (eofflg .ge. 0) 1 then C NOW we are testing the date range validly. However, we must adjust C 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. C FORTUNATELY we saved the appropriate length of month adjustment C above so can add it back in here. IWF=0 most times. iss=issss+iwf jx = ihd - iss + 1 C need a little more logic to handle crossing months here c where jx >7 we have to adjust by length of month once more... if (jx .gt. 7) jx=jx+iwf c also have to handle cases where we crossed months, by adding in c length of previous month. if (jx .le. 0) jx=jx+ml(im) 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 apts(jx,jy) = .not. tflg C Derived a long time ago C end if end if prveof = eofflg end do C while C 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,7) 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 do c 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) C Go through the entire Do (j=1,19) C array and display If ( apts(i,j) ) then C appts if they exist: jx = 6 * j + 10 C jx is x coord of cursor jy = 3 * i - 1 C jy is y coord of cursor If ( jx .gt. 74) then C For afternoon and evening jy = jy + 1 C appointments, put the jx = jx - 63 C appointments on the second End If C line of the day jj = j C Now decode the time again call dtcat(jx,jy) C to display. jj is time if (((j/2)*2) .ne. j) then C of appointment jj = jj + 7 - (jj/2) C If the time is odd then write(iterm,16) jj C it falls on the hour. 16 format($,i2,':00') else jj = jj + 7 - (jj/2) C If the time is even then write(iterm,17) jj C it falls on the half hour 17 format($,i2,':30') end if End If end do end do 999 call dtcat(1,22) C move cursor to the bottom end C of the screen and return C -h- year.for Tue Jul 8 16:06:21 1986 c----------------------------------------------------------------------- C Year-at-a-glance subroutine C part of Mitch Wyle's DTC program C Input: c line - 72 INTEGER*1 string; Format: Y [yy] C Output: c display screen (see below) C----------------------------------------------------------------------- c SUBROUTINE year C (line) c Declarations: include comdtc.INC include escdtc.INC INTEGER*1 temp(4), ln1 Character*4 tempc Equivalence(tempc,temp(1)) Character*2 tempc2 Equivalence(tempc2,temp(1)) C temporary string converting array Integer*4 id, idr C Julian Day Integer*4 im, imr C Julian Month Integer*4 iye, iyr C Julian Year Integer*4 iyo C y offset for where to put month data Integer*4 ix C x coord of cursor Integer*4 iy C y coord of cursor Integer*4 img C month loop index goes from 1 to 12 Integer*4 jg C index offset defined by img Integer*4 ii C implied do loop index variable INTEGER*1 monthn(9) C string month name real badf77 real badftn C Maybe error in array subscripts c string containing names of days of week character*21 wknam C Hoolay kan INTEGER*1 ihold C hold the screen c Entries true if length of name is even logical*1 lmneven(12) equivalence (line, ln1) include comdtcd.inc include escdtcd.inc Data wknam 1 / 'Su Mo Tu We Th Fr Sa|'/ Data lmneven/ 1 .false., .true., .false., .false., .false., .true., 2 .true., .true., .false., .false., .true., .true./ if ((ln1 .and. ucmask) .eq. ichar('Y')) 1 call shrink(1, ifnb, lnb) call dtcdatcvt(1) C Parse out a year value im=idmo id=iddy iye=ibigyr c call dtcidate(imr,idr,iyr) C initialize to today's date C to display in reverse video c set screen to 132 col, double width for write(iterm,300) esc,'[0;0H',esc,'[1J' C Erase screen first in this mode... write(iterm,300) esc,'[?3h', 1 esc,'[2H', esc,'#6', 2 esc,'[14H', esc,'#6' C Month headers Write(tempc,20,err=97)iye c encode (4, 20, temp, err=97) iye 20 format(i4) 97 ix = 29 iy = 11 call dtcat(ix,iy) C Display year in write(iterm,305) esc,dhdw1, temp C double height/double width c *******&&&& ?????? C in the middle of the screen iy = 12 call dtcat(ix,iy) write(iterm,305) esc,dhdw2, temp C second line 99 Do 4 img = 1,12 C for each month: call dtcmthnam(img,monthn) C Find out name, and display it jg = img - 1 C x coord of cursor for month if (jg .gt. 5) jg = jg - 6 C name in outstring ix = ( jg * 22 ) + 1 C if (img .gt. 6) then C First six months on top iy = 14 C last six months on bottom else C half of screen iy = 2 end if c ixx = (ix/2) + 2 c *** if (lmneven(img)) ixx = ixx + 1 call dtcat(ix,iy) c call dtcat(ixx,iy) C Position cursor and: write(iterm,3) monthn 3 format($,21a1) C Write out the name. 300 format($,40a) 305 format($, 2a, 4(x, a)) 399 format($,a21) C Write out the name. If (img .gt. 6) then C Write out day of week iy = 15 C Header names also, one else C line below month names iy = 3 end if call dtcat(ix,iy) write(iterm,399) wknam If (img .gt. 6) then C Write out numbers for iy = 15 C Days in each month: iyo = 12 else iy = 4 iyo = 0 end if call dtcalcdow(ib,il,img,iye) C Now position the month ix = ix - 1 C 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 video if ((iye .eq. iyr) .and. (img .eq. imr)) then idw = mod(ib + idr -2, 7) C Day of week and iwm = (idr + ib - 2)/7 C week of month (orig 0) if (img .gt. 6) iwm = iwm + 1 C Down one more line for Jul-Dec call dtcat((idw * 3) + ix + 1, iy + iwm) write (iterm, 301) esc,'[5;7m', idr, esc,resetvattr 301 format ($, 2a, i2, 2a, $) end if 4 Continue call dtcat (1,23) C Reposition cursor c return next line read in and allow main pgm to decode... Rewind 7 read(7,80,END=914)line Rewind 7 80 format(84a1) 914 Continue Rewind 7 write(iterm,300) esc,'[?3l' Rewind 7 Return end C -h- strip.for Tue Jul 8 16:06:45 1986 c----------------------------------------------------------------------- C Strip Daily Appointment subroutine (DTC Purge command) C part of GLENN EVERHART'S MODS TO DTC program C Input: command line - 72 INTEGER*1s, format: C P [mmddyy] c or c U [mmddyy] [hh:mm[>hh:mm]] c or c X [mmddyy] [hh:mm[>hh:mm]] [mmddyy] [hh:mm[>hh:mm]] C Output: c Reads dtc.dat, and builds new dtc.dat, in the process c strips old appointments (before date) from file (P), c deletes appointments at specified time and date (U), c or re-schedules (eXchanges) appointments from d1*t1 to d2*t2 c for Amiga, since we don't have version numbers, build DTC.TMP and c copy onto DTC.DAT (or whatever) later... C----------------------------------------------------------------------- c SUBROUTINE strip C (line) C Declarations: c include comdtc.INC include apptdtc.INC c C Function constants: Purge C .. Unschedule parameter (idspp = 1) Parameter (idspu = 2) Parameter (idspx = 3) C .. eXchange C INTEGER*1 line(1) C input line C temporary string converting array INTEGER*1 temp(2), ll, 1 ln1, ap1 C For RDAPPT 'do while' loop Integer*4 eofflg, prveof, 1 firstflg Integer*4 id, idx C Julian Day Integer*4 im, imx C Julian Month Integer*4 iye, iyx C Julian Year Integer*4 it1, it2, itx1, itx2 C time values 80 (8 AM) => 173 (5:30 PM) c logical first C For X decode Character*1 ln1c equivalence (line, ln1) c equivalence (appoin, ap1) Equivalence (ln1,ln1c) include stmtfuncsp.for include comdtcd.inc c include stmtfunc.for C Get standard statement functions c Parse input line: c Was there a P on the front? If so, trim it off: c iopn2=0 c flag we opened DTC.TMP, 1 if true... isavinc = incmod C Save for increment in DATCVT first = .true. C Set it regardless of path If ( ln1c .eq. 'P' ) then idisp = idspp C Function to perform else if (ln1c .eq. 'U') then idisp = idspu else if (ln1c .eq. 'X') then idisp = idspx else go to 999 C Error, can't decode it end if it1 = 80 C Set comparison values it2 = 180 itx1 = it1 itx2 = it2 End If call shrink (1, ifnb, lnb) if (ifnb .eq. 0) then if (idisp .eq. idspp) then call dtcidate(im,id,iye) C set to today's date else go to 999 C Not enough info for U or X end if else C If the date was specified in command line then c set id, im and iye to the right values: c 10 call dtcdatcvt(3) C (line) if (first) then C Note we decode into im = idmo C second set of values, id = iddy C then copy into first set iye = ibigyr C first (or only) time around end if C (unlike Schlitz, we can go around twice) if (idisp .ne. idspp) then C other than purge c *** itx2 = 175 C Set default for '*' or call dtctimcvt(itx1, itx2) if (itx1 .eq. itx2) 1 itx2 = itx2 + 1 C Add (10 mins) to allow semi-open interval if (first) then it1 = itx1 it2 = itx2 if (idisp .eq. idspx) then if (ln1 .eq. 0) go to 999 C Error if nothing left first = .false. go to 10 C Re-cycle code end if C Done unless X end if else C P, guarantee no redisplay ln1 = 0 C Zap the line end if C Done parse for U, X end if C Done date/time parse ixhash = ihymd(iye, im, id) C Calc hash for day of interest c *** type 950, ixhash c *** 950 format(2z9.8) if (idisp .eq. idspp) 1 then C Set request date for RDAPPT irqhash(1) = ixhash C Delete before else irqhash(1) = 0 C Look at everybody end if irqhash(2) = Z'7FFFFFFF' C 'Til the end of time firstflg = 0 C Zero until file opened for write prveof = 0 eofflg = -1 do while (prveof .ge. 0) call dtcrdappt(eofflg, 1) C Look at control entries if (eofflg .gt. 0) 1 then eofflg = 0 C Don't open it on return go to 190 C but re-write it as is C Test it now else if (eofflg .eq. 0) 1 then c *** type 950, irchash iht = min0(max0(iht, 80), 173) C Insure a kosher time value go to (110, 120, 130) idisp C Dispatch on numeric value go to 190 C Bad call, re-write anyway? 120 if ((irchash .eq. ixhash) .and. 1 ((iht .ge. it1) .and. (iht .lt. it2))) 2 go to 100 C Criteria for Unscheduling (deleting) go to 190 C Do re-write 130 if ((irchash .eq. ixhash) .and. 1 ((iht .ge. it1) .and. (iht .lt. it2))) 2 then iht = itx1 + (iht - it1) C Get updated time if (mod(iht, 10) .eq. 6) iht = iht + 4 C go to next hour if (iht .gt. itx2) go to 100 C Duration was shortened ihy = ibigyr C Change dates ihm = idmo ihd = iddy end if C Usually re-write c 110 continue C Purge, re-write C Can't open output till 190 if (firstflg .eq. 0) 1 then C we have input C close(3) c open(unit=3, file=FNc(1:fnsz), status='NEW', c 1 form='FORMATTED', c 1 err=999) 9991 continue open(unit=3, file='DTC.TMP', status='NEW', 1 form='FORMATTED', 1 err=999) iopn2=1 c flag we got DTC.TMP open... firstflg = 1 C Output now open end if write (3, 201,err=9991) ihy, ihm, ihd, iht, 1 apptstr(1:min0(max0(iaptln, 1), iaptlim)) c *** 1 (appoin(k), k=1, min0(max0(iaptln, 1), iaptlim)) 201 format(i4.4, 2i2.2, i3.3, x, a) C New format, 19850806113 end if C eofflg 100 prveof = eofflg C Set loop condition end do C while C Purged everything? if (firstflg .eq. 0) 1 then C create empty file close(3) c open(unit=3, file=FNc(1:fnsz), status='NEW', c 1 form='FORMATTED', c 1 err=999) open(unit=3, file='DTC.TMP', status='NEW', 1 form='FORMATTED', 1 err=999) iopn2=1 firstflg = 1 C Output now open end if if(iopn2.le.0)goto 9403 c Amiga ... c rewind 1 and 2, then copy DTC.TMP into DTC.DAT (or wherever) c Rewind 1 close(1) close(4) open(unit=4, file=FNc(1:fnsz), status='NEW', 1 form='FORMATTED',err=999) c re-open unit 4 if we can, for write... c Rewind 3 close(3) open(unit=3, file='DTC.TMP', status='old', 1 form='FORMATTED', 1 err=999) 9402 continue Read (3,201,end=9401,err=9401) ihy,ihm,ihd,iht,apptstr c read temp file, write back new appt file write (4, 201,err=9401) ihy, ihm, ihd, iht, apptstr c 201 format(i4.4, 2i2.2, i3.3, x, a) goto 9402 9401 continue close(3,Status='delete') close(4) firstflg=0 iopn2=0 9403 continue close(3) close(2) close(4) close(1) C Done with new files return 999 write (iterm, 990) C Error on decode, write nastygram 990 format($,'Syntax or file-open (write) error.', $) ln1 = 0 C Inhibit rescan c end C -h- dtcdatcvt.for Tue Jul 8 16:07:21 1986 c Date conversion function (part of DTC), derived from DATMUN, c except decodes the values directly into DEFDAT and shrinks LINE, c rather than schlep LINE back and forth to kingdom come. C Modified 850422, CG, to restrict values of month/day/year C modified 850325, 850726 & 850731, CG, to allow any of the following: c d{d}/m{m}/{y}y, d, dd, dmm, ddmm, dmmyy, ddmmyy, dmmyyyy, ddmmyyyy c for D or W functions c m{m}/{y}y, m, mm, myy, mmyy, mmyyyy, myyyy for M c y, yy, yyy, yyyy for Y C plus dd-mon-yy, dd-mm-yy, dd-xii-yy formats C function: c Convert a line starting with a date of form c mmddyy OR mm/dd/yy OR dd-mon-yy OR dd-romn-yy c to binary equivalents, and remove from line, copying binary values c to DEFDAT in common. C Leaves whatever follows the date alone. c Added for DTC to not have to use such a crock date c format as the original; too hard to use otherwise. Subroutine dtcdatcvt (nf) C (line,nf) c c implicit none c Integer*4 nf C Number of fields expected c include comdtc.INC c INTEGER*1 nb, l1, l2, l3, l4, lxx(4), work(icmln), tb6(6) C, c C lengths of months (30 days hath Sept ...) Integer*4 lm(12) c C Min chars to recognize month names Integer*4 minln(12) C Decode month names, or European style w/ Roman months character*4 rch,mab(12),rom(12) Integer*4 i, k, kkk, n, nn, ix, ixyr, ixmo, ixdy, nfd, 1 ifnb, lnb, lcount logical longyr C If year entered as 3 chars or more integer*2 iwk(42), lw1 integer*1 iwkk(84),ln1 Character*1 ln1c Equivalence (work,iwkk) C 2 chars at a time c Integer*4 ll1 equivalence(line(1),ln1) equivalence (ln1,lw1),(ll1,rch) equivalence (rch, lxx), (work, iwk) equivalence(line(1),ln1c) c Integer*4 icvt10, icur INTEGER*1 ich include stmtfuncsp.for include comdtcd.inc Data lm 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ c C Min chars to recognize month names Data minln 1 /2, 1, 3, 2, 3, 3, 3, 2, 1, 1, 1, 1/ C Decode month names, or European style w/ Roman months Data 1 mab / 'JANU', 'FEBR', 'MARC', 'APRI', 'MAY ', 'JUNE', 2 'JULY', 'AUGU', 'SEPT', 'OCTO', 'NOVE', 'DECE'/, 3 rom / 'I ', 'II ', 'III ', 'IV ', 'V ', 'VI ', 4 'VII ', 'VIII', 'IX ', 'X ', 'XI ', 'XII '/ include stmtfunc.for icvt10(icur, ich) = (icur * 10) + icvtbn1(ich) C conversion function stage c Begin code longyr = .false. C set default of century calculation c Initialize default values for omitted fields ixyr = ibigyr C Copy current values ixmo = idmo C from common ixdy = iddy if (numeric(ln1)) then C Dates must start with number work(1) = ln1 C Copy first character ix = icvtbn1(ln1) C Compute value on the fly c do (n = 2, (nf * 2) + 2) C Allow [mm][dd][yyyy] c l1 = line(n) C Copy current character C Field separators: slash if (l1 .eq. ichar('/')) 1 go to 100 C for mm/dd/yy form C .. dash if (l1 .eq. ichar('-')) 1 go to 200 C for dd-mmm-yy form if ((l1 .eq. ichar(':')) .or. (l1 .eq.ichar('>'))) 1 go to 999 C hour-string first, return default values C anything else: if (.not. numeric(l1)) 1 go to 300 C mmddyy, minus some characters, fake whatever is required work(n) = l1 C Don't recopy ix = icvt10(ix, l1) C continue conversion end do n = (nf * 2) + 3 C Set shrink value if no delimiter go to 300 C Go convert it else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) then k = incmod C Save current value call dtcdatinc C Convert incremental date incmod = k C Restore else if (ln1c .eq. '=') then kkk = 1 C Place holder, strip only, date n/c go to 950 end if C (don't want to reformat whole file) go to 999 C All done here c handle mm/dd or mm/dd/yy{yy} (for D, W, M or Y) c or mm/yy{yy} (for M or Y) 100 continue C Here for '/' encountered in first scan loop k = n + 1 C next character to look at l1 = line(k) if (.not. numeric(l1)) go to 300 C nnnn/x ??? ixmo = ix C First field is always month in "/" notation ix = icvtbn1(l1) C Start 2nd conversion do (n = k + 1, 20) C should be plenty l1 = line(n) C get character if (l1 .eq. ichar('/')) go to 110 C Found second / if (.not. numeric(l1)) go to 120 C End of scan ix = icvt10(ix, l1) C convert end do n = 21 C Set it 120 if (nf .eq. 3) then ixdy = ix C 2nd field is day else ixyr = ix C .. year longyr = ((n - k) .gt. 2) end if go to 900 110 l1 = line(n+1) C Found 2nd slash, check for third field if (.not. numeric(l1)) go to 120 C left field C k = n + 1 ixdy = ix C 2nd has to be day ixyr = icvtbn1(l1) C Start 3rd conversion (year) do (n = k + 1, 20) C get more numerics l1 = line(n) if (.not. numeric(l1)) go to 910 ixyr = icvt10(ixyr, l1) end do n = 21 C mark next character go to 910 C set for SHRINK c handle dd-mon-yy, dd-mm-yy, or dd-roman-yy 200 continue C Here for '-' in first scan loop ixdy = ix C Copy converted day field rch = ' ' C initialize for alpha month name, or Roman numerals k = n + 1 C next char after "-" l1 = line(k) if (numeric(l1)) then C European format dd-mm-yy ixmo = icvtbn1(l1) C go for it directly do (n = k + 1, 20) l1 = line(n) if (.not. numeric(l1)) go to 210 ixmo = icvt10(ixmo, l1) end do n = 21 else if (alpha(l1)) then lxx(1) = l1 .and. z'5F5f5f5f' C Set first char for name or roman lcount = 1 do (nn = k + 1, k + 6) C should find "-" by then l1 = line(nn) if (l1 .eq. ichar('-')) go to 230 C Start search if (.not. alpha(l1)) go to 230 C also terminate if (lcount .lt. 4) then C room for at least one more lcount = lcount + 1 lxx(lcount) = l1 .and. z'5F5f5f5f' C Copy character end if end do nn = k + 6 230 continue do (i = 1, 12) C Loop over months if (rch .eq. rom(i)) go to 250 C Found match in roman set if (lcount .ge. minln(i)) then if (rch(1:lcount) .eq. mab(i)(1:lcount)) 1 go to 250 C Found match in alpha names end if C Note: last two IF statements above replace original horrendous sequence of c IF-THEN-ELSEs to see if month was J then A, or F, or M then A then R, etc C end do c Fell out of loop, leave current month go to 300 C Unknown month or roman seq, back up before "-" 250 ixmo = i C iwk(1) = icvtbcd(i) n = nn C Accept characters else C "-" followed by non alphanumeric go to 300 end if 210 if (l1 .ne. ichar('-')) go to 900 C See if year follows k = n + 1 l1 = line (k) if (.not. numeric(l1)) go to 910 C First dash is left ixyr = icvtbn1(l1) do (n = k + 1, 30) l1 = line (n) if (.not. numeric(l1)) go to 910 ixyr = icvt10(ixyr, l1) end do n = 31 910 longyr = ((n - k) .gt. 2) C Set logic value go to 900 300 continue C Short string found, fix it up nfd = n/2 C Number of 2-char groups found longyr = (nfd .gt. nf) C check for default or forced century if ((n .and. 1) .eq. 0) then C Example: n = 5 for 4 chars found (0 mod 2) work(1) = '0' C Force even number of characters do (i = 2, n) work(i) = line(i - 1) C Shift line over by 1 end do end if go to (310, 320, 330) nf C Dispatch on # expected fields go to 900 C Bad value ??? 310 ixyr = ix C take year: Y [yy] go to 900 C End case 320 ixmo = icvtbin(iwkk(1)) C M mm if (nfd .eq. 2) ixyr = icvtbin(iwkk(3)) C M {m}myy if (nfd .eq. 3) ixyr = mod(ix, 10000) C M {m}myyyy go to 900 C End case 330 if (nfd .eq. 1) ixdy = icvtbin(iwkk(1)) C D {d}d {only} if (nfd .ge. 2) then C D [mm]dd[yy] ixmo = icvtbin(iwkk(1)) C D {m}mdd ixdy = icvtbin(iwkk(3)) C D {m}mdd end if if (nfd .eq. 3) ixyr = icvtbin(iwkk(5)) C D {m}mddyy if (nfd .eq. 4) ixyr = mod(ix, 10000) C D {m}mddyyyy 900 continue C common clean-up & return C Check for 1-99 AD if ((ixyr .lt. 100) .and. (.not. longyr)) 1 ixyr = ixyr + ((ibigyr/100)*100) C add "current" century if (islpyr(ixyr)) 1 then lm(2) = 29 C Set for Leap Years else lm(2) = 28 C reset for "common" years end if ibigyr = ixyr C Explicit year idmo = min0(max0(ixmo, 1), 12) C Limit values iddy = min0(max0(ixdy, 1), lm(idmo)) C .. kkk = n - 1 C Change index of next char to count 950 idyr = mod(ibigyr, 100) C Set value if (kkk .gt. 0) 1 call shrink (kkk, ifnb, lnb) C Unload the stuff we used 999 return C Miscellaneous exits end c -h- dtctimcvt.for Tue Jul 8 16:08:13 1986 c Subroutine to extract and convert time-of-day string for DTC package c Converts string of form hh:mm to Integer*4 between 80 and 173 c (half-hour intervals). If range h1:m1>h2:m2 is present, second c value is returned, else same as t1>t1. c Special cases c * => {itr1}>{itr2} c E or EV => 17:00 c h: => 0h:00 c h:n => 0h:n0 (if n .ge. 3, then 3, else 0) c h1>h2 => h1:00>h2:00 c If ':' or '>' is not 2nd or 3rd character, or not '*', 'E' or 'EV', c entire string is left untouched, and default values are returned c (parameters unchanged) subroutine dtctimcvt (itr1, itr2) include comdtc.INC INTEGER*1 ll, ln1, wk(2) integer*2 iwk character*2 icwk equivalence(icwk,iwk) integer*1 iwkk logical first, expectmin equivalence (line(1), ln1), (iwk, wk) equivalence(iwkk,wk(1)) include stmtfuncsp.for include comdtcd.inc include stmtfunc.for it1 = itr1 C Caller's limits it2 = itr2 C (formerly 8:00 AM > 5:30 PM) ix = 0 C Amount to strip if(ln1.gt.96)ln1=ln1-32 if (ln1 .eq. ichar('*')) then C Check special cases first ix = 1 C Defaults, dump 1 char else if ((ln1 ) .eq. ichar('E')) then it1 = 170 C Set eventide it2 = it1 ix = 1 if(line(2).gt.96)line(2)=line(2)-32 if ((line(2)) .eq. ichar('V')) ix = 2 else i = 0 C Temp index first = .true. C Helpful 10 if (numeric(line(i+1))) then if (numeric(line(i+2))) then wk(1) = line(i+1) wk(2) = line(i+2) read(icwk,850)ih 850 format(BZ ,I2) ih=ih*10 c ih = icvtbin(iwkk) * 10 i = i + 2 else ih = icvtbn1(line(i+1)) * 10 i = i + 1 end if if (line(i+1) .eq. ichar(':')) then i = i + 1 if (numeric(line(i+1))) then im = icvtbn1(line(i+1)) if (im .ge. 3) then im = 3 else im = 0 end if ih = ih + im i = i + 1 if (numeric(line(i+1))) i = i + 1 C Just ignore it end if ix = i C Accept all processed chars end if if ((ih .ge. 10) .and. (ih .lt. 70)) 1 ih = ih + 120 C Force early AM to PM ih = min0(max0(ih, 80), 180) C Normalize within limits if (line(i+1) .eq. ichar('>')) then i = i + 1 ix = i C Insure it gets copied it2 = ih if (first) then it1 = it2 first = .false. go to 10 end if else if (ix .ne. 0) then C Got some numeric if (first) then it1 = ih C terminated by ':' it2 = ih C first time t1>t1 else it2 = ih C 2nd numeric ix = i C Claim everything looked at end if C Which time end if C Range delimiter ('>') end if C First numeric end if C All others unrecognized (includes EOL) itr1 = it1 C All exit here itr2 = max0(it2, it1) C Make sure range OK if (ix .ne. 0) call shrink (ix, ifnb, lnb) C Unload what we've used end C -h- shrink.for Tue Jul 8 16:08:41 1986 c Subroutine to shift LINE to left after current item has been scanned c deletes blanks between that point and first non-blank character c Performs no operation if current item is EOL (binary 0) c Sets return arguments pointing to first and last non-blank characters subroutine shrink (iskip, ifnbr, lnbr) c include comdtc.INC INTEGER*1 ll include comdtcd.inc ifnb = 0 lnb = 0 if (line(1) .eq. 0) go to 999 C Exit immediately ix = iskip + 1 C start looking do while ((ix .le. icmln) .and. (line(ix) .ne. 0)) if (line(ix) .gt. 32) go to 10 C Found something ix = ix + 1 end do line(1) = 0 C 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 C Stop at EOL if (ll .gt. 32) lnb = i ix = ix + 1 end do line(min0(lnb+1, icmln)) = 0 C Flag EOL if not found 999 ifnbr = ifnb C Set return values lnbr = lnb end C -h- dtcat.for Tue Jul 8 16:09:05 1986 subroutine dtcat(ic,ir) C x, y c include comdtc.INC C Need ITERM include escdtc.INC C include comdtcd.inc include escdtcd.inc write(iterm,773) 773 format(' ') c write once to flush extra junk out... then position. write(iterm, 2, err=3) esc,'[',ir,';',ic,'H' 2 format($,2a1,i2.2,a1,i3.3,a1,$) C Max rows is 2-digit number c return c 3 write (iterm,10) esc,homescrn, ir, ic 10 format($, 2a, 'Error in DTCAT, row/col =', 2z5.4, ' (hex).') end C -h- gaby.for Tue Jul 8 16:10:23 1986 c----------------------------------------------------------------------- C Subroutine Gaby C Part of Mitch Wyle's DTC program C return a string corresponding to the month number c Month number contained in im. Send back string in monthn. c (JANUARY for 1, etc.) C----------------------------------------------------------------------- C modified 850315 - Center month names in table, use mixed case - CG SUBROUTINE gaby(im,monthn) C Declarations: c INTEGER*1 monthn(9) C Table of month names and numbers (centered, even lengths biased left): c INTEGER*1 months(9,14) character*9 monthch(14) equivalence (months, monthch) C Select the right month and fill monthn with it: c Data monthch/ 'December ', 1 ' January ', 'February ', ' March ', ' April ', 2 ' May ', ' June ', ' July ', ' August ', 3 'September', ' October ', 'November ', 'December ', 4 ' January '/ C ALLOW FOR OVERFLOWS... IMM=IM+1 c *** monthn = monthch(imm) C String assignment c Do 1 i=1,9 C INTEGER*1-at-a-time Monthn(i) = months(i,imm) 1 Continue c All done. return end c -h- ICVT routines Integer*2 function Icvtbin(ich2) Character*2 ich2 Character*2 wrk integer*2 iwrk,ians Equivalence(wrk,iwrk) c convert 2 digit Integer*4 to number c avoid trick version from VAX that depends on byte c ordering (which fails on MC68000). wrk=ich2 Read(wrk,1,err=2)ians 1 Format(BN,I2) 2 Continue Icvtbin=ians Return End Function Icvtbn1(nnn) Integer*1 nnn Integer*4 kkk kkk=48 if(nnn.ge.48.and.nnn.le.57)kkk=nnn kkk=kkk-48 c return 0 or digit value... Icvtbn1=kkk Return End d subroutine dely d Integer*4 idly,i1 d common/xxxyyy/idly d idly=0 d do 1 i1=1,15000 d idly=idly+i1 d1 continue d idly=idly/100 d return d end