home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 300-399 / ff335.lzh / DTC / Dtc2.For < prev    next >
Text File  |  1990-03-22  |  97KB  |  3,952 lines
  1. C -h- dtcvax.for  Tue Jul  8 16:01:48 1986
  2. c------------------------------------------------------------------------
  3. C               Desk Top Calender Program
  4. C                                                     Mitch Wyle 17.11.82
  5. C       This program provides an on-line appointment calender system
  6. c       for daily appointments, week-at-a-glance schedule, and month-
  7. c       at-a-glance schedule.  A facility is provided for a daily re-
  8. c       minder.
  9. C       The program has help and menu prompting facilities for the new
  10. c       user and the ability to interpret an MCR line for the experienced
  11. c       user.  The CRT screen functions are specific to the DEC VT-100
  12. c       screen terminal, as is the FORTRAN code.
  13. C------------------------------------------------------------------------
  14. C       Compile:
  15. C------------------------------------------------------------------------
  16.  
  17. c       Declarations:
  18.  
  19.       include comdtc.INC
  20. C Get common file
  21.       include escdtc.INC
  22. C Frequently-used escape sequences
  23.       include appdtc.Inc
  24. c Initialize common declared above
  25.       include dtcxidate.inc
  26.       INTEGER*1 ln1
  27.       Character*1 ln1c
  28. c first character of line
  29.       integer*2 ln2
  30.       integer*1 incsel(4)
  31.       logical exflag
  32. C first two characters of line
  33.       character*84 comlin
  34.       character*9 fnamech
  35. c      character*60 fnamchh
  36. c      character*18 fname
  37. C Make FORTRAN OPEN happy
  38.       equivalence (comlin, line(1))
  39.       equivalence (line(1),ln1)
  40.       equivalence (ln1, ln2)
  41.       Equivalence (ln1,ln1c)
  42. c      equivalence (line(1),ln1)
  43.       equivalence (fname,fnamech)
  44. c      equivalence (fnamchh,fname)
  45.  
  46.       character*2 khomescrn,kclrscrn,kdhdw1,kdhdw2,
  47.      1 kdwide,kresetvattr,krevattr
  48.       Integer*4  kincmod
  49.       include stmtfuncsp.for
  50.       Data comlin /' '/
  51.       Data fnamech /'DTC.DAT'/
  52. C Make FORTRAN OPEN happy
  53. C Length of default value
  54.        include comdtcd.inc
  55.        include escdtcd.inc
  56.       data khomescrn /'[H'/, kclrscrn /'[J'/,
  57.      1    kdhdw1 /'#3'/, kdhdw2 /'#4'/, kdwide /'#6'/,
  58.      2    kresetvattr /'[m'/, krevattr /'[7m'/
  59.  
  60.       data kincmod /1/
  61. C Default to day
  62.  
  63. c End common initialization
  64.  
  65. C INCMOD will flag day/week/month/year default increment...
  66. c 1=day, 2=week, 3=month,4=year
  67.       Data incsel /'D', 'W', 'M', 'Y'/
  68. C Auto display after +/-
  69.  
  70. C       Integer*4  lib$get_foreign
  71. C Get DCL command line, unparsed
  72.  
  73.       Data exflag/.false./
  74. C True if data on DCL command line
  75.  
  76.       include stmtfunc.for
  77. C Get useful statement functions
  78.  
  79. c Begin code:
  80.        fname(18)=0
  81.        fnsz=9
  82.        comlen=0
  83.        comidx=0
  84.        homescrn=khomescrn
  85.        clrscrn=kclrscrn
  86.        dhdw1=kdhdw1
  87.        dhdw2=kdhdw2
  88.        dwide=kdwide
  89.        resetvattr=kresetvattr
  90.        revattr=krevattr
  91.        incmod=kincmod
  92. c       Iterm=9
  93. c first set up default data filename
  94. C >>> Assumes VT100, interactive <<<
  95. 980   continue
  96. c Escape sequences used:
  97. C       <ESC>7          Save cursor and video attributes
  98. c       <ESC>8          Restore ...
  99. c       <ESC><          Exit ATS mode
  100. c       <ESC>>          Keypad numeric mode (Exit Alternate Keypad mode)
  101. c       <ESC>[?4l       Reset scroll mode (jump)
  102. c       <ESC>[?6l       Reset origin mode (absolute)
  103. c       <ESC>[r         Set top/bottom margins (default - 1:24)
  104. c       <ESC>[m         Graphic rendition = primary (default)
  105. c       <ESC>[H         Set cursor at home position (upper left)
  106. c       <ESC>(B         G0 (SI/^O) = US ASCII
  107. c       <ESC>)0         G1 (SO/^N) = Special graphics
  108. c       ^O              Shift In (Select G0 (US ASCII))
  109.  
  110. C Clean up terminal
  111. C [m
  112.       write (*,100)
  113.      1 esc,'<', esc,'>',
  114.      2 esc,'[?4l', esc,resetvattr,
  115.      4 esc,'7', esc,'[?6l', esc,'[r', esc,'8'
  116. c       write(*,100) esc,'[0;0H',esc,'[26t',esc,'[138u'
  117. c set private Amiga modes to inhibit wrap...
  118. c set so smallfont will (we hope) have all positions available.
  119.  100    format ($, 21a, $)
  120. C Escape sequences
  121.       ibigyr=1987
  122.       iddy=4
  123.       idmo=7
  124.       call dtcidate(idmo,iddy,ibigyr)
  125. C Get current date
  126.           call dtcicomd
  127.  
  128. c       First time, get the MCR line, then parse and process it:
  129.  
  130. c INIT  exflag=.false.
  131. C Assume terminal input
  132.  
  133. C       istat=lib$get_foreign(comlin,,comlen)
  134. C       if ((istat .ne. ss$_normal) .or. (comlen .eq. 0))
  135. C       1   go to 77
  136.       GOTO 77
  137. c Allow for single operation to insert an appointment in upper & lower case
  138.  
  139. C       if (ln1 .eq. '"') then
  140. C User quoted the line
  141. C           do (i = 2, comlen)
  142. C First of many re-copy opns
  143. C               line(i-1) = line(i)
  144. C copy it down
  145. C           end do
  146. C           comlen = comlen - 1
  147. C       end if
  148.  
  149. C       line(min0(comlen+1, icmln)) = 0
  150. C Set end of line character
  151. C       exflag=.true.
  152. C Flag for exit after one command
  153.  
  154. c Generalized parser and scanner routine for line:
  155.  
  156.  1      continue
  157. C Loop up here on any input.
  158.  
  159. c initialize flags to normal search display sense (show occupied times)
  160. c and no special meeting setups...
  161.  
  162.       rdspfg=0
  163.       ctlfg=0
  164.  
  165.  1111   continue
  166. C Re-enter here, after "+", etc
  167.  
  168.       comidx = 1
  169. C Initialize for parsing
  170.  
  171.       if (lcalpha(ln1))
  172.      1   ln1 = ln1 -32
  173. C Change to upper case
  174. c Find out what's seen in the line...
  175.       If ((ln1c .eq. 'D')
  176.      1   .or. (ln1c .eq. '=')
  177.      2   .or. (ln1c .eq. '*'))
  178.      3 then
  179.           incmod=1
  180.           call day
  181. C (line)
  182. C display daily,
  183.           go to 6
  184.  
  185.       else if (ln1c .eq. 'W')
  186.      1 then
  187.           incmod=2
  188.           call week
  189. C (line)
  190. C weekly,
  191.           go to 6
  192.  
  193.       else if (ln1c .eq. 'M')
  194.      1 then
  195.           incmod=3
  196.           call month
  197. C (line)
  198. C or monthly schedules,
  199.           go to 6
  200.  
  201.       else if (ln1c .eq. 'Y')
  202.      1 then
  203.           incmod=4
  204.           call year
  205. C (line)
  206. C or full-year calendar
  207.           go to 6
  208.  
  209. c flag multiple schedule of meeting to enable multi entry
  210.       else if (ln1c .eq. 'S')
  211.      1 then
  212.           ln1c='D'
  213.           ctlfg=1
  214.           incmod=1
  215.           call day
  216. C (line)
  217.           go to 6
  218.  
  219. c use G as a schedule that will write appointments in current and
  220. c all indirected files.
  221.       else if (ln1c .eq. 'G')
  222.      1 then
  223.           ln1c='D'
  224.           ctlfg=2
  225.           incmod=1
  226.           call day
  227. C (line)
  228.           go to 6
  229.  
  230.       else if ((ln1c .eq. '+') .or. (ln1c .eq. '-'))
  231.      1 then
  232.           Call dtcdtinc
  233. C (line,Incmod)
  234.           if (ln1 .ne. 0) go to 450
  235. C something left, schedule it
  236.  
  237.           ln1c = incsel(incmod)
  238. C Phony line
  239.           line(2) = 0
  240. C End-of-line ?
  241.           comlen = 1
  242.           go to 1111
  243. C Display based on incr
  244.  
  245. c reverse display flag so we hunt up free slots... note week, month
  246. c routines all get hacked on to do this...
  247. c reparse line after copying it down 1 character to remove the 'N'
  248.       else if (ln1c .eq. 'N')
  249.      1 then
  250.           rdspfg=1
  251.           call shrink(1, ifnb, lnb)
  252.           go to 1111
  253.  
  254.       else if (ln1c .eq. 'P')
  255.      1 then
  256. C Purge old appointments
  257.           call strip
  258. C (line)
  259.           go to 6
  260.  
  261.       else if ((ln1c .eq. 'U') .or. (ln1c .eq. 'X'))
  262.      1 then
  263.           call strip
  264. C (line)
  265. C Cancel or reschedule
  266.           if (ln1c .gt. ' ') go to 1
  267. C Re-scan if leftover chars
  268.           go to 6
  269.  
  270.       else if (ln1c .eq. 'L')
  271.      1 then
  272. c for locating free time, use week function and scan map
  273.           ctlfg=1
  274.           ln1c='W'
  275.           incmod=2
  276.           call week
  277. C (line)
  278.           go to 6
  279.  
  280.       else if (ln1c .eq. 'T')
  281.      1 then
  282.           ln1c='D'
  283.           incmod=1
  284.           call day
  285. C (line)
  286. C today's memos then exit
  287.           go to 999
  288.  
  289.       else if (ln1c .eq. 'R')
  290.      1 then
  291.           ln1c='W'
  292.           incmod=2
  293.           call week
  294. C (line)
  295. C remind one of this week
  296.           go to 999
  297.  
  298.       else if (ln1c .eq. 'C')
  299.      1 then
  300. C calendar print for month
  301.           incmod=3
  302.           call month
  303. C (line)
  304.           go to 999
  305.  
  306.       else if (ln1c .eq. 'I')
  307.      1 then
  308. C Reset default date
  309.           call dtcicomd
  310. C Process possible date string
  311.           go to 6
  312. C (for testing mods)
  313.  
  314.       else if ((ln1c .eq. 'H') .or. (ln1c .eq. '?'))
  315.      1 then
  316.           call dhelp
  317. C HELP
  318. C (instructions)
  319.           go to 6
  320.  
  321. c f filename enters new default data file name to use...
  322.       else if (ln1c .eq. 'F')
  323.      1 then
  324.           call shrink(1,ifnb, lnb)
  325.           if (ifnb .eq. 0)
  326.      1     then
  327.         fnamech = 'DTC.DAT'
  328.         fnsz = 7
  329. C Length of default value
  330.             else
  331.         do (i=1,lnb)
  332.             fname(i)=line(i)
  333.         end do
  334.         fnsz=lnb
  335.           end if
  336.           fname(fnsz+1)=0
  337. C Make FORTRAN OPEN happy
  338.           go to 6
  339.  
  340.       else if ((ln1c .eq. 'Q') .or.
  341.      1 ((line(1).eq.ichar('E').or.line(1).eq.ichar('e')).and.
  342.      2 (line(2).eq.ichar('X').or.line(2).eq.ichar('x')))) then
  343.           go to 999
  344. C Exeunt omnes
  345.  
  346.       else
  347.  
  348. C       Now get a bit fancy:  (play with the line string)
  349. c
  350.       if (ln1c .eq. 'E') go to 450
  351. c
  352.       If (.not. numeric(ln1)) go to 5
  353. C unknown
  354. c
  355.  450    continue
  356. C From E above, or leftovers for +/-
  357. C The first character is a number or E,
  358. c call the daily appointment subroutine:
  359.  
  360.       incmod=1
  361.       line(icmln) = 0
  362. C Tag e/o/l
  363.       call day
  364. C (line)
  365.       go to 6
  366.  
  367.       End If
  368. c
  369.  5      continue
  370. C First character not recognized
  371.  
  372. c Line was uninterpretable, so display menu:
  373.  
  374.  77     call menu
  375. C Also display menu first time if no command
  376.  
  377.  6      continue
  378. C get a new line and hop back up...
  379.       if (exflag) go to 999
  380. C DEBUG: Display remains of line after operations on it
  381. C
  382. C       iln = 1
  383. c
  384. C       do i = 1, icmln
  385. c
  386. C       if (line(i) .eq. 0) line(i) = O'32'
  387. C control Z, displays as BLOT
  388. c
  389. C       if (line(i) .gt. ' ') iln = i
  390. c
  391. C       end do
  392. c
  393. C       WRITE(*,93) (line(i), i= 1, iln)
  394. c
  395. C 93    format(' ', <iln>a1, ': DTC: ',$)
  396.        call dtcat(1,22)
  397.        write(*,93)
  398.  93     format(/,' DTC: ',$)
  399. c ---   comlin = ' '
  400. C Initialize w/ blanks
  401.        read (*, 7, end=999)  comlin
  402.  7      format(a)
  403.        Do 750 n=1,80
  404.        nnn=81-n
  405.        comlen=nnn
  406.        if(comlin(nnn:nnn).gt.' ')goto 751
  407.        comlin(nnn:nnn)=char(0)
  408. 750    continue
  409. 751    continue
  410.  
  411. c Mark only stuff read from terminal
  412. c (don't want command-input call to try to read terminal)
  413.  
  414.       line(min0(comlen+1, icmln)) = 0
  415. C mark for old-style tests
  416.  
  417.       go to 1
  418.  
  419.  999    continue
  420. C EXit, Quit, or ^Z
  421.       stop
  422.       end
  423. C -h- dtcdatinc.for       Tue Jul  8 16:07:46 1986
  424.       Subroutine dtcdtinc
  425. C (Line,Incmod)
  426.  
  427. c routine to add or subtract sidereal units (days, weeks, months or years)
  428.  
  429. c incmod = 1 for day            (in COMMON)
  430. c        = 2 for week
  431. c        = 3 for month
  432. c        = 4 for year
  433.  
  434. c format is
  435. c  +nn or -nn : add/subtract nn default units
  436. c  +/- nnu (u=d,w,m,y) to add/subt that unit
  437.  
  438. c output in defdat
  439.  
  440.       include comdtc.INC
  441.  
  442.       INTEGER*1 ln1, ll
  443.       Character*1 ln1c
  444. c ml is 14 long to allow refs out of bounds to l for no. days in month...
  445.  
  446. C length of months - Dec, Jan ... Dec, Jan
  447.       Integer*4  l(12), ml(14)
  448.  
  449.       equivalence (l(1), ml(2)), (line, ln1)
  450.       Equivalence(ln1,ln1c)
  451.        include stmtfuncsp.for
  452.        include comdtcd.inc
  453.  
  454.        Data ml /31, 31,28,31, 30,31,30, 31,31,30, 31,30,31, 31/
  455.        include stmtfunc.for
  456.  
  457. c Begin code
  458.  
  459.       l(2) = 28
  460. C Initialize (may have been changed below)
  461.  
  462.       isign=1
  463. C Called only if + or - is first char of LINE
  464.       if (ln1c .eq. '-')
  465.      1   isign = -1
  466.  
  467. c now grab off digits...
  468.  
  469.       magn=0
  470. C Initialize magnitude of value
  471.  
  472.       do (n = 2, icmln)
  473.           ll = line(n)
  474.           if (.not.( numeric(ll))) go to 5
  475. C Exit first non-numeric
  476.           magn = (magn * 10) + icvtbn1(ll)
  477.       end do
  478.  
  479.       n = icmln
  480. C This many numeric, no overflow???
  481.  
  482.  5      continue
  483.  
  484.       if (magn .eq. 0)
  485.      1   magn = 1
  486.  
  487.       if (alpha(ll))
  488.      1 then
  489.  
  490.           ll = ll .and. ucmask
  491.  
  492. c scan for d,w,m,y for units
  493.  
  494.           if (ll .eq. ichar('D'))
  495.      1     then
  496.         incmod=1
  497.             else if (ll .eq. ichar('W')) then
  498.         incmod=2
  499.             else if (ll .eq. ichar('M')) then
  500.         incmod=3
  501.             else if (ll .eq. ichar('Y')) then
  502.         incmod=4
  503.             else
  504.         n = n - 1
  505. C Don't strip one we didn't use: alpha
  506.           end if
  507.  
  508.         else
  509.  
  510.           n = n - 1
  511. C Don't strip one we didn't use: non-alpha
  512.  
  513.       end if
  514.  
  515.       call shrink(n, ifnb, lnb)
  516. C Shift LINE over
  517.  
  518. c magn now has magnitude, isign has sign and incmod has type of increment.
  519.  
  520.       if (incmod .le. 2)
  521.      1 then
  522.           inctyp = 1
  523.  
  524. c adjust weeks as being 7 * days and treat together
  525.  
  526.           if (incmod .eq. 2)
  527.      1  magn = magn * 7
  528.  
  529.         else
  530.           inctyp = incmod - 1
  531.  
  532.       end if
  533.  
  534. c inctyp is 1 for day or week, 2 for month, 3 for year
  535.  
  536.       if (inctyp .eq. 1)
  537.      1  then
  538. C Moving by days
  539.           iddy = iddy + (isign * magn)
  540.  
  541. c loop point if we move forward
  542.  
  543.  100        if (iddy .gt. l(idmo))
  544.      1     then
  545.  
  546.         lyd = 0
  547.  
  548. c account for leap years where february is 29 days long...
  549.  
  550.         if (islpyr(ibigyr) .and. (idmo .eq. 2))
  551.      1      lyd = 1
  552.  
  553.         iddy = iddy - l(idmo) - lyd
  554.         idmo = idmo + 1
  555.  
  556.         if (idmo .gt. 12)
  557.      1    then
  558.             idmo = 1
  559.             ibigyr = ibigyr + 1
  560.         end if
  561.  
  562.         goto 100
  563.  
  564.           end if
  565.  
  566. c loop point if we move back
  567.  
  568.  110        if (iddy .le. 0)
  569.      1     then
  570.  
  571. c account for leap years. note ml is prev month so check def mo = 3
  572.  
  573.         lyd = 0
  574.         if (islpyr(ibigyr) .and. (idmo .eq. 3))
  575.      1      lyd = 1
  576.  
  577.         iddy = iddy + ml(idmo) + lyd
  578.         idmo = idmo - 1
  579.         if (idmo .le. 0)
  580.      1    then
  581.             idmo = 12
  582.             ibigyr = ibigyr - 1
  583.  
  584.         end if
  585.  
  586.         goto 110
  587.  
  588.           end if
  589.  
  590.         else if (inctyp .eq. 2) then
  591. C moving by months
  592.  
  593.           idmo = idmo + (isign * magn)
  594.  
  595.  200        if (idmo .gt. 12)
  596.      1     then
  597.  
  598.         idmo = idmo - 12
  599.         ibigyr = ibigyr + 1
  600.  
  601.         goto 200
  602.  
  603.           end if
  604.  
  605.  300        if (idmo .le. 0)
  606.      1     then
  607.  
  608.         idmo = idmo + 12
  609.         ibigyr = ibigyr - 1
  610.  
  611.         goto 300
  612.  
  613.           end if
  614.  
  615.         else if (inctyp .eq. 3) then
  616.           ibigyr = ibigyr + (isign * magn)
  617.  
  618.       end if
  619.  
  620.       if (inctyp .ge. 2)
  621. C months or years
  622.      1 then
  623. C Must check if we exceed month length
  624.  
  625.           if (islpyr(ibigyr))
  626.      1     then
  627.         l(2) = 29
  628.             else
  629.         l(2) = 28
  630.           end if
  631.  
  632.           iddy = min0(iddy, l(idmo))
  633. C force last day of month, if necessary
  634.  
  635.       end if
  636.  
  637.       idyr = mod(ibigyr, 100)
  638. C Restrict to current 'century'
  639.  
  640.       end
  641.  
  642. C -h- menu.for    Tue Jul  8 16:02:05 1986
  643. c-----------------------------------------------------------------------
  644. C       Menu subroutine
  645. C       part of Mitch Wyle's DTC program
  646. C       Inputs:
  647. c               None
  648. C       Output:
  649. c               display screen (see below)
  650. C-----------------------------------------------------------------------
  651. c
  652.  
  653.       SUBROUTINE menu
  654.  
  655. C       Declarations:
  656. c
  657.  
  658.       include comdtc.INC
  659. C Need ITERM
  660.       include escdtc.INC
  661. C       INTEGER*1 esc /27/
  662. c       Integer*4  iterm/6/
  663.        include comdtcd.inc
  664.         include escdtcd.inc
  665.  
  666. C       Initialize:
  667. c
  668.  
  669. c       iterm = 6
  670. C       Output terminal unit number
  671. c       esc = O'033'
  672.  
  673. c       call dtcat(1,1)
  674.        write(*,1) esc,homescrn, esc,clrscrn
  675. C       clear screen
  676.  1      format($,4a, $)
  677. c
  678.        write(*,2) ' ', esc,dhdw1
  679. C       double-height
  680.  2      format($,3a,13X,'D T C   C o m m a n d s')
  681. C       ..
  682. c      write(*,2) ' ', esc,dhdw2
  683. C       double-width
  684. c
  685.       write(*,3)
  686.  3      format(/,1x,
  687.      1  8x,'D [mmddyy]   -     Appointment Schedule for dd mm yy',/,
  688.      2  8x,'W [mmddyy]   -     Week-At-A-Glance for week of dd mm yy',
  689.      3  /,8x,'M [mmyy]     -     Month-At-A-Glance for mm yy',/,
  690.      4  8x,'Y [yy]       -     Full Year calendar for yy',/,
  691.      5  8x,'+ or - nnZ   -     Add/Subt nn Z (Z=D,W,M,Y): change date',
  692.      5  /,
  693.      6  8x,'N(cmd str)   -     Reverse display sense of M or W cmd',
  694.      6     ' (free time)',/,
  695.      7  8x,'L [mm]dd[yy] n -   Locate time (n * 30 mins.) free for mtg')
  696.        Write(*,303)
  697. 303    format(
  698.      8  8x,'hh:mm>hh:mm  -     Add or change appointments for hh:mm',/,
  699.      9  8x,'EV (pseudo time) - Add or change EVening appointment',/,
  700.      1  8x,'P [mmddyy]   -     Purge appointments prior to mmddyy',/,8x,
  701.      2  'U [mmddyy] t1[>t2] <cmd> - Unschedule (cancel) appointments',/,
  702.      3  8x,'X d1 t1 d2 t2 <cmd> - eXchange (reschedule) appointments',/,
  703.      3  8x,'    (then execute <cmd> if present)', /,
  704.      4  8x,'S [mmddyy]   -     Schedule multiple activity on mmddyy',/,
  705.      4  8x,'    (Drops notices in all indirected users files also)',/,
  706.      5  8x,'G [mmddyy]   -     File activities in multiple files',/,
  707.      6  8x,'F FILENAME   -     Change default data file to Filename',/,
  708.      7  8x,'I            -     Reset default date to today.',/,
  709.      8  8x,'H or ?       -     Help!',/,
  710.      9  8x,'Q or  EX     -     Exit')
  711. C After all that
  712. c
  713.       return
  714. c
  715.       end
  716. C -h- dtcidate.for        Tue Jul  8 16:02:23 1986
  717.       subroutine dtcidate (imr, idr, iyr)
  718. C Testing aid for DTC - allows for phony value of current date to be
  719. c returned to caller, for verifying displays, etc
  720. C Calling sequence - same as Fortran IDATE
  721. c
  722.       include comdtc.INC
  723.       include dtcxidate.INC
  724.       include defcentry.INC
  725.        include escdtc.inc
  726.       include comdtcd.inc
  727.       include escdtcd.inc
  728. c
  729.       if (xim .eq. 0) then
  730. C Assumes linker initializes to zero
  731.  
  732.           call date (xim, xid, xiy)
  733.           if(xiy.gt.100)xiy=mod(xiy,100)
  734.           xibgyr = icntry + xiy
  735.           if(xibgyr.lt.100)xibgyr=xibgyr+1900
  736. C Set long value
  737.  
  738.       end if
  739.  
  740.       imr = xim
  741.       idr = xid
  742.       iyr = xibgyr
  743.  
  744.       end
  745.       subroutine dtcicomd
  746. C Process "I" command: if no arguments, reset dummy IDATE to current date,
  747. c else call dtcdatcvt to parse a date string, store those values in
  748. c XIDATE common.
  749.  
  750.       include comdtc.INC
  751.       include dtcxidate.INC
  752.       include escdtc.inc
  753.       include defcentry.INC
  754.  
  755.       INTEGER*1 ln1
  756.       Character*1 ln1c
  757.       equivalence (line(1), ln1)
  758.       equivalence(ln1,ln1c)
  759.  
  760.       include comdtcd.inc
  761.       include escdtcd.inc
  762.  
  763.  
  764.       call shrink(1, ifnb, ilnb)
  765. C Unload command character
  766.  
  767.       if (ln1 .eq. 0)
  768.      1 then
  769.  
  770.           call date (xim, xid, xiy)
  771.           if(xiy.gt.100)xiy=mod(xiy,100)
  772.           xibgyr = icntry + xiy
  773.           if(xibgyr.lt.100)xibgyr=xibgyr+1900
  774. C Reset
  775.  
  776. c          xibgyr = icntry + xiy
  777. C Set long value
  778.  
  779.           ibigyr = xibgyr
  780. C Set values into common
  781.  
  782.           idmo = xim
  783.           iddy = xid
  784.           idyr = xiy
  785.  
  786.         else
  787.  
  788.           call dtcdatcvt (3)
  789. C Parse string
  790.  
  791.           xim = idmo
  792. C Set test values
  793.           xid = iddy
  794.           xiy = idyr
  795.  
  796.           xibgyr = ibigyr
  797.  
  798.       end if
  799.  
  800.       end
  801. C -h- dtcrdappt.for       Tue Jul  8 16:02:38 1986
  802.       subroutine dtcrdappt (eofflg, indflg)
  803.  
  804. c search through appointment files for entries matching range of hash values.
  805. c opens files if EOFFLG set on entry. INDFLG controls whether indirect files
  806. c should be opened as encountered, and whether caller wants to look at indirect
  807. c entry or not:
  808.  
  809. c       INDFLG
  810. c         -1    No processing @
  811. c          0    Normal processing
  812. c         +1    Return before opening @
  813.  
  814. c       EOFFLG  Entry                   Exit
  815. c         -1    Initialize              EOF return
  816. c          0    Normal re-entry         Normal return, valid entry
  817. c         +1    Open @ file             Return for @ filename found
  818.  
  819. c Processes both old- and new-format files
  820. c       Old: yymmddhhh appt (possibly no blank between HHH & APPT)
  821. c       New: yyyymmddhhhh appt
  822.  
  823. c Created 19850802, CG, using some code removed from DAY subroutine
  824.  
  825. c      implicit none
  826.  
  827.       Integer*4  eofflg, indflg
  828. C i/o, i only
  829.  
  830.       include comdtc.INC
  831.       include apptdtc.INC
  832.       include defcentry.INC
  833. C Default century for old format
  834.       include escdtc.inc
  835.       character*1 nullch
  836. C Old old files had trailing NULs
  837.       include stmtfuncsp.for
  838.       Integer*4  i, ij, lth, istrend, nunit
  839.  
  840.       Data nullch/0/
  841.       include comdtcd.inc
  842.       include escdtcd.inc
  843.       include stmtfunc.for
  844.  
  845. c Begin code
  846.  
  847. c ***   type 950, irqhash
  848. c 950   format(2z9.8)
  849.  
  850.       if (eofflg .lt. 0)
  851. C Start scan
  852.      1 then
  853.  
  854.           nunit=1
  855.           close(1)
  856.           Open (unit=nunit, file=FNc(1:fnsz),
  857.      1     status='OLD',action='READ',
  858.      1    form='FORMATTED', err=99)
  859.  
  860.           eofflg = 0
  861. c ***   type  *, ' Opened file'
  862.       end if
  863.  
  864. c loop back up here to continue reading and processing input file:
  865.  
  866.       do while (eofflg .ge. 0)
  867.  
  868.  900    format( a)
  869. C Read all
  870.  901    format(3i2, i3)
  871. C Decode old
  872.  902    format(i4, 2i2, i3)
  873. C Decode new
  874.  
  875.           if (eofflg .gt. 0)
  876.      1     then
  877. C must open indirect file
  878.  
  879.         eofflg = 0
  880.  
  881. c ***   type 951, work(istart)
  882. c *** 951       format (' ', a)
  883.         Do (nnn=1,80)
  884.          ilst=81-nnn
  885.          if(workstr(ilst:ilst).gt.' ') goto 952
  886. c find index of end string (last nonspace char)
  887.         End Do
  888. 952     continue
  889.         nunit = 2
  890.         close(2)
  891.         Open (unit=nunit, file=workstr(istart:ilst), status='old',
  892.      1        form='formatted', action='READ',
  893.      2        err=1067)
  894.  
  895.           end if
  896.  
  897.           read (nunit, 900, end=400,err=400) workstr
  898. c find lth now by hand
  899. c assume 80 char work array max
  900.          do 705 i705=1,80
  901.          lth=81-i705
  902.          if(workstr(lth:lth) .gt. ' ') goto 706
  903.          workstr(lth:lth)=nullch
  904. 705      continue
  905. 706      continue
  906. c ***   type  *, ' ', workstr
  907. C Look for non-blank
  908. C & non-null
  909.           do (i = min0(lth, iwrkln), 1, -1)
  910.         if ((workstr(i:i) .ne. ' ')
  911.      1      .and. (workstr(i:i) .ne. nullch))
  912.      2  go to 10
  913. C Break
  914.           end do
  915.  
  916.           i = 1
  917. C All blank entry ???
  918.  
  919.  10         lth = i
  920.  
  921. c String is filled with blanks regardless of length of record
  922.  
  923.           if (chnumeric(workstr(10:10)))
  924.      1     then
  925. C new format
  926.         read(workstr, 902, err=30) ihy, ihm, ihd, iht
  927.         istart = 12
  928. C Index of first valid character
  929. c ***   type  *, ' New format'
  930.  
  931.             else
  932. C       Old format
  933.  
  934.  30             continue
  935. C       Retry old
  936.         read(workstr, 901, err=300) ihy, ihm, ihd, iht
  937.         ihy = ihy + icntry
  938. C       Insert current century
  939.  
  940.         istart = 10
  941. C Assume old, old format
  942.  
  943. c ***   type  *, ' Old format'
  944.  
  945.           end if
  946. C (workstr(10) is numeric)
  947.  
  948.           if (workstr(istart:istart) .eq. ' ')
  949.      1  istart = istart + 1
  950. C Index of first valid character
  951.  
  952.           iwkln = max0((lth - istart) + 1, 1)
  953.           istrend = (istart + iwkln) - 1
  954.           iaptln = max0(min0(iwkln, icmln), 1)
  955.  
  956.           if (ihm .eq. 99)
  957.      1     then
  958.  
  959.         ihy = 9999
  960. C set all fields
  961.         ihd = 99
  962.         iht = 999
  963.  
  964.         if ((indflg .ge. 0) .and. (nunit .eq. 1))
  965.      1    then
  966.  
  967.             call fnscan(work(istart), icmln - istart + 1,
  968.      1                  iwkln, ij)
  969. C Common code to check filename
  970.  
  971.             if (ij .ne. 0)
  972.      1        then
  973. C Skip if no file
  974.  
  975. c ***   type *, ' IJ = ', ij
  976.                 eofflg = 1
  977.  
  978.                 if (indflg .gt. 0)
  979.      1            then
  980.  
  981.                     apptstr = workstr(istart:istrend)
  982.  
  983.                     return
  984. C DAY, STRIP want a look
  985.  
  986.                 end if
  987. C Found 1
  988.  
  989.             end if
  990. C non-null file-name
  991.  
  992.         end if
  993. C valid place for indirect
  994.  
  995.             else
  996. C not filename flag in record
  997.  
  998.         irchash = ihymd(ihy, ihm, ihd)
  999. C Compute hash for record
  1000.  
  1001. c ***   type 950, irchash
  1002.  
  1003.         if ((irchash .ge. irqhash(1))
  1004.      1      .and. (irchash .le. irqhash(2)))
  1005.      2    then
  1006. C Found record within range, exit
  1007.  
  1008.             apptstr = workstr(istart:istrend)
  1009.  
  1010. c ***   type *, ' Returning'
  1011.            return
  1012. C Break out of loop
  1013. 400                continue
  1014. C no more appointments left in file.
  1015. c ***   type  *, ' EOF'
  1016.            if (nunit .eq. 1)
  1017.      1        then
  1018. C Which file were we reading?
  1019.                eofflg = -1
  1020. C real end of file
  1021.              else
  1022. 1067                   close (2)
  1023. C Error opening indirect file
  1024.                nunit=1
  1025.            end if
  1026. C Which unit had EOF
  1027.        end if
  1028. C Hash range test
  1029.          end if
  1030. C type of record
  1031. 300        continue
  1032. C Error decoding y/m/d/t fields
  1033.       end do
  1034. C Read next line from current file
  1035.       close (1)
  1036. C Close first-level
  1037. 99     continue
  1038. C Failed first open
  1039.       end
  1040. C -h- dtcmthnam.for       Tue Jul  8 16:03:02 1986
  1041.       SUBROUTINE dtcmthnam (im,monthn)
  1042. c-----------------------------------------------------------------------
  1043. C       Subroutine dtcmthnam (formerly GABY)
  1044. C       Part of Mitch Wyle's DTC program
  1045. C       return a string corresponding to the month number
  1046. c       Month number contained in IM.  Send back string in MONTHN.
  1047. c       (JANUARY for 1, etc.)
  1048. C-----------------------------------------------------------------------
  1049. C       Modified 850315 - Center month names in table, use mixed case - CG
  1050. c       Modified 850802 - Renamed DTCMTHNAM
  1051.  
  1052. C       Declarations:
  1053. c
  1054.       INTEGER*1 monthn(9)
  1055. c ***   character*9 monthn
  1056. C Can't use, char params expect descriptor
  1057.  
  1058. C       Table of month names and numbers (centered, even lengths biased left):
  1059. c
  1060.  
  1061.       INTEGER*1 months(9,14)
  1062.       character*9 monthch(14)
  1063.  
  1064.       equivalence (months, monthch)
  1065. C       Select the right month and fill monthn with it:
  1066.       Data monthch/           'December ',
  1067.      1 ' January ', 'February ', '  March  ', '  April  ',
  1068.      2 '   May   ', '  June   ', '  July   ', ' August  ',
  1069.      3 'September', ' October ', 'November ', 'December ',
  1070.      4 ' January '/
  1071.  
  1072. c
  1073.  
  1074. C ALLOW FOR OVERFLOWS...
  1075.       IMM=IM+1
  1076. c ***   monthn = monthch(imm)
  1077. C String assignment
  1078. c
  1079.       Do (i=1,9)
  1080. C byte-at-a-time
  1081.           Monthn(i) = months(i,imm)
  1082.       end do
  1083.  
  1084. c       All done.
  1085.  
  1086.       end
  1087. C -h- dtcalcdow.for       Tue Jul  8 16:03:26 1986
  1088.         SUBROUTINE dtcalcdow(ib,il,im,iyx)
  1089. c-----------------------------------------------------------------------
  1090. C       DTCALCDOW subroutine
  1091. C       part of Mitch Wyle's DTC program
  1092. C       Inputs:
  1093. c               im      -       month (number 1-12)
  1094. c               iy      -       year  (number 0-9999)
  1095. C       Outputs:
  1096. c               ib      -       integer corresponding to day of week
  1097. c                               on which the month begins (1-7)
  1098. c               il      -       length of the month in days
  1099. C       Modified 850117 by CG because it thought New Years 1985 was on Monday
  1100. c               when it really was on Tuesday (not counting intervening
  1101. c               leap years between 1982 and current as having 366 days).
  1102. c       Modified 850724 by Glenn Everhart to work for years between 1900
  1103. c               and 1982 (formerly thought all intervening years started
  1104. c               on Friday)
  1105. c       Modified 850726 by CG to simplify days-since-base calculation.
  1106. c               NOTE: Has been reworked to calculate all dates AS IF
  1107. c               the Gregorian Calendar had been in effect since AD 1,
  1108. c               and that the Gregorian correction for 100 and 400
  1109. c               will be valid indefinitely (the 1928 Episcopal
  1110. c               Book of Common Prayer indicates this is valid at least
  1111. c               until AD (or CE) 8400, but I don't think I, or anybody
  1112. c               reading this code within the forseeable future will be
  1113. c               around to verify whether it does or doesn't!), see note
  1114. c               just before IDAYS computation.  It will also try to compute
  1115. c               if a negative year is input (i.e., BC) but probably won't be
  1116. c               valid since there was no year zero.  If any calendar phreak
  1117. c               wants to figure it out for the Julian calendar, have fun,
  1118. c               just keep in mind that the Gregorian superseded the Julian
  1119. c               at different times and in different ways in different localities
  1120. c               (October 4, 1582 was followed by October 15 in Catholic
  1121. c               countries, and another "long sleep" occurred in September 1752
  1122. c               in English-speaking realms, but apparently in Sweden
  1123. c               the change was effected by omitting Leap Years
  1124. c               until the calendar got back in sync
  1125. c               (there is a story of a man who didn't celebrate his first
  1126. c               birthday until he was sixty years old, leaving Frederic
  1127. c               of Pirates of Penzance with little to complain about)
  1128. C               Russia, Romania, Greece and Turkey did not convert until
  1129. c               the twentieth century.
  1130. C               P.S.: 4th parameter (input year) is no longer modified.
  1131. C       Modified 850729 by CG - Get rid of loop that added number of days of
  1132. c               each month --- why sum a sequence of constants?
  1133. c       Modified 850802 by CG - renamed from DANY to DTCALCDOW, removed
  1134. c               default century and previously commented-out code
  1135. c       Modified 850809 by CG - Insure IB output in range 1..7: negative values
  1136. c               (from negative year input) caused DTCDSPMTH to zap its
  1137. c               character arrays and display some verrry strange-looking months
  1138. C-----------------------------------------------------------------------
  1139. c
  1140. c       Declarations:
  1141. c Base value for IDAYS, day-of-week for January 1, AD 1
  1142. C
  1143.       parameter (idow = 2)
  1144.       Integer*4  im
  1145. C       Julian Month
  1146.       Integer*4  iyx, iy
  1147. C       Julian Year
  1148.       Integer*4  lpyear
  1149. C       Define additive variable
  1150.        include stmtfuncsp.for
  1151. c Array of months and number days
  1152.        Integer*4 months(12)
  1153. C in each one
  1154. c array of months containing d/o/w
  1155.        Integer*4  bomdow(12)
  1156. C of first day of month
  1157.  
  1158.       Data months
  1159.      1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
  1160. C in each one
  1161.  
  1162. c array of months containing d/o/w
  1163.       data bomdow
  1164.      1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 /
  1165. C of first day of month
  1166.       include stmtfunc.for
  1167. C Need ISLPYR function
  1168. c
  1169. c Begin code
  1170. c
  1171.       iy = iyx
  1172. C Copy parameter
  1173. c Take care of leap years:
  1174.       lpyear = 0
  1175. C Assume "common" year
  1176.       if (islpyr(iy))
  1177.      1 then
  1178.           months(2) = 29
  1179. C length of February in leap year
  1180.           if (im .gt. 2) lpyear = 1
  1181. C Add one to BOM DOW after Feb
  1182.         else
  1183.           months(2) = 28
  1184. C .. "common" year
  1185.       end if
  1186.  
  1187. c Rather than add up all of the days since January First, AD 1
  1188. c (which would have been a Monday had the Gregorian calendar been in effect then),
  1189. c we note that the day of week of 1 January advances by 1 day per year,
  1190. c plus another day the year AFTER a leap year, etc, therefore just add
  1191. c values of years, leap years, century years, etc, modulo 7, to figure out
  1192. c day of week of the month we are interested in.
  1193.  
  1194.       itemp = iy - 1
  1195. C not including current year
  1196. C Day of week of 1/1/0001
  1197. C plus number of years
  1198. C plus number of leap years
  1199. C less even hundreds
  1200. C but add back even four hundreds
  1201. C plus day of week for BOM
  1202.       idays = idow
  1203.      1  + itemp
  1204.      2  + (itemp/4)
  1205.      3  - (itemp/100)
  1206.      4  + (itemp/400)
  1207.      5  + bomdow(im)
  1208.      6  + lpyear
  1209. C plus 1 for March or later in leap year
  1210.  
  1211.       ib = mod ( idays , 7 )
  1212. C Find day of week 0:6
  1213.       if (ib .le. 0) ib = ib + 7
  1214. C In case IY was negative (Sun is day 1)
  1215.       il = months(im)
  1216. C Length of the current month
  1217.  
  1218.       end
  1219. C -h- dtcdspmth.for       Tue Jul  8 16:03:45 1986
  1220.       SUBROUTINE dtcdspmth (ib,il,xoff,xspa,YOFF,yspa)
  1221.  
  1222. c-----------------------------------------------------------------------
  1223. C       DTCDSPMTH month printing subroutine (formerly MISCHY)
  1224. C       part of Mitch Wyle's DTC program
  1225. C       Inputs:
  1226. c               ib      -       begining day of the week
  1227. c               il      -       length of month in days
  1228. c               xoff    -       offset for x coordinate
  1229. c               xspa    -       number of spaces to skip between numbers
  1230. c               yoff    -       offset for y coordinate
  1231. c               yspa    -       number of lines to skip between lines
  1232. C       Output:
  1233. c               display screen (see below)
  1234. C       Modified 850301, CG - write full line at a time, rather that each date
  1235. c       Modified 850802, CG - Renamed from mischy
  1236. C-----------------------------------------------------------------------
  1237. c
  1238.  
  1239. c       Declarations:
  1240.  
  1241.       Integer*4    ib
  1242. C       beginning day of the week
  1243.       Integer*4  il
  1244. C       length of month in days
  1245.       Integer*4  xoff
  1246. C       x offset
  1247.       Integer*4  xspa
  1248. C       number of spaces between numbers
  1249.       Integer*4  yoff
  1250. C       y offset
  1251.       Integer*4  yspa
  1252. C       number of lines to skip between lines
  1253.  
  1254.       include comdtc.INC
  1255. C Need ITERM
  1256.       include escdtc.INC
  1257.  
  1258.       Integer*4  ix
  1259. C       x coordinate of where to put day
  1260.       Integer*4  iy
  1261. C       y coordinate of where to put day
  1262.       Integer*4  ip
  1263. C       the day of the week for date in hand
  1264.       Integer*4  ixo
  1265. C       xoff + 1
  1266.  
  1267. c numbers as characters
  1268.       Integer*2  nums(31)
  1269.       Integer*2  wknums(7)
  1270. c 1      format('+',6(a2,<ix>x),a2)
  1271.       Character*1 nmfmt(18)
  1272.       Character*2 nmff
  1273.       Character*18 nmfm
  1274.       Equivalence(nmfm,nmfmt(1)),(nmfmt(10),nmff)
  1275.       Data nmfm/'($,6(1A2,01X),1a2)'/
  1276.       Data nums
  1277.      1 /      ' 1', ' 2', ' 3', ' 4', ' 5', ' 6', ' 7', ' 8', ' 9',
  1278.      2  '10', '11', '12', '13', '14', '15', '16', '17', '18', '19',
  1279.      3  '20', '21', '22', '23', '24', '25', '26', '27', '28', '29',
  1280.      4  '30', '31'/
  1281.  
  1282.       include comdtcd.inc
  1283.       include escdtcd.inc
  1284. C To contain copies of above, or blanks
  1285.  
  1286. c Begin code
  1287.  
  1288.       do (i = 1, 7)
  1289. C       One week's worth
  1290.           wknums (i) = '  '
  1291. C       initialize
  1292.       end do
  1293.       ip = ib
  1294.       ix = xspa + 1
  1295. C       Used in format # 1
  1296.       ixo = xoff + 1
  1297.       iy = 4 + YOFF
  1298.  
  1299. c Now write month out to screen, one week at a time:
  1300.  
  1301.       Do (i = 1, il)
  1302.  
  1303.           wknums(ip) = nums(i)
  1304. C       Get day as character
  1305.           If ( ip .eq. 7 )
  1306. C       is it Saturday again?
  1307.      1     then
  1308.         call dtcat(ixo,iy)
  1309. C       Position cursor for line
  1310.         write(nmff,110)ix
  1311.         write(*,nmfm)wknums       
  1312. c        write (*,1) wknums
  1313. C       Write filled array
  1314.         ip = 1
  1315. C       reset day to Sunday.
  1316.         iy = iy + 1 + yspa
  1317. C       move down one line
  1318.             else
  1319.         ip = ip + 1
  1320. C       increment day number
  1321.           End If
  1322.  
  1323.       end do
  1324.  
  1325.       if (ip .ne. 1)
  1326. C       Partial buffer remains
  1327.      1 then
  1328.  
  1329.           call dtcat(ixo,iy)
  1330. C       Position cursor
  1331. c          write (*,1) (wknums(i), i = 1, ip - 1)
  1332.        write(nmff,110)ix
  1333. 110    format(i2.2)
  1334.        write(*,nmfm)(wknums(i),i=1,ip-1)       
  1335. 1      format($,a2,1x,$)
  1336.         Write(*,223)
  1337. 223     format(/,1x)
  1338. c emit trailing crlf...
  1339. cC       Write rest of array
  1340.        end if
  1341.  
  1342. c 1      format('+',6(a2,<ix>x),a2)
  1343.       end
  1344. C -h- dhelpvax.for        Tue Jul  8 16:04:30 1986
  1345. c-----------------------------------------------------------------------
  1346. C       Help subroutine
  1347. C       part of Mitch Wyle's DTC program
  1348. C       Inputs:
  1349. c               None
  1350. C       Output:
  1351. c               display screen (see below)
  1352. C-----------------------------------------------------------------------
  1353. c
  1354.  
  1355.       SUBROUTINE dhelp
  1356.  
  1357.       include comdtc.INC
  1358.       include escdtc.INC
  1359. c
  1360.  
  1361. c       Integer*4  iterm/6/
  1362. c       INTEGER*1 esc/O'033'/
  1363.         INTEGER*1 buf(79)
  1364.          include comdtcd.inc
  1365.          include escdtcd.inc
  1366.  
  1367. C       Initialize:
  1368. c
  1369.  
  1370. c       iterm = 6
  1371. C       Output terminal unit number
  1372. c       esc = o'033'
  1373.  
  1374.       call dtcat(1,1)
  1375.        write(*,91) esc,homescrn, esc,clrscrn
  1376. C       clear screen
  1377.        write(*,1) ' ', '    D T C  -  Desk Top Calendar'
  1378. c      write(*,1) ' ', esc,dhdw2, '    D T C  -  Desk Top Calendar'
  1379. c
  1380.  1      format(40a)
  1381.  91     format($,4a, $)
  1382.  
  1383.       Open (unit=1,file='DTC.HLP',action='READ',form='FORMATTED',
  1384.      1  status='OLD', err=9)
  1385.  
  1386.       Do (i=1, 22)
  1387.           Read(1,4,end=5) buf
  1388.         do 301 n=1,78
  1389.         ibln=79-n
  1390.         if(buf(ibln).gt.32)goto 302
  1391.         buf(ibln)=0
  1392. 301     continue
  1393. 302     continue
  1394.           if (ibln .ne. 0) then
  1395.         write (*,6) (buf(j), j=1,ibln)
  1396.           else
  1397.         write (*,6)
  1398.           end if
  1399.        end do
  1400. c
  1401.  4      format(100a1)
  1402.  6      format(1x,100a1)
  1403. c
  1404.  5      close(unit=1)
  1405. C Read end-of-file
  1406.        return
  1407. c
  1408.  9      write(*, 99)
  1409.  99     format(' Help file C:DTC.HLP not found')
  1410.     Return
  1411.        end
  1412. C -h- day.for     Tue Jul  8 16:04:45 1986
  1413. c-----------------------------------------------------------------------
  1414. C       Daily Appointment subroutine
  1415. C       part of Mitch Wyle's DTC program
  1416. C       Input:
  1417. c       line - 72 INTEGER*1s;  Format: D [mmddyy [hh:mm>HH:MM [appointment]]]
  1418. C       Output:
  1419. c               display screen (see below)
  1420. C-----------------------------------------------------------------------
  1421. C       Modified 850314, CG, to write day-of-week to daily-appointment screen,
  1422. c          and note current time if current day displayed (reverse video)
  1423. c       Modified 19850802, CG, to write full date as well, and handle both new-
  1424. c          and old-format appointment files.
  1425. c       Modified 851218, CG: change default range of appointment from whole day
  1426. c          to 8:00 only
  1427. C       Modified 860220, CG: Check for duplicate appointment times,
  1428. c          move and flag them
  1429.  
  1430.       SUBROUTINE day
  1431. C (line)
  1432.  
  1433. c       Declarations:
  1434.  
  1435.       include comdtc.INC
  1436.       include apptdtc.INC
  1437.       include escdtc.INC
  1438.  
  1439.       character*100 apstr
  1440.       INTEGER*1 appnt(icmln)
  1441. C       appointment string
  1442.       INTEGER*1 temp(2), ll, ln1, ap1
  1443.       Character*1 ln1c
  1444. C       temporary string converting array
  1445.  
  1446.       INTEGER*1 blot
  1447. C       ^Z, for entry from display
  1448.  
  1449.       Integer*4    id, idr
  1450. C       Julian Day
  1451.       Integer*4  im, imr
  1452. C       Julian Month
  1453.       Integer*4  iye, iyr
  1454. C       Julian Year
  1455.       Integer*4  idx, imx, iyx, isx
  1456. C copies for calling DANY
  1457.       integer*1 ibsp
  1458.       Integer*4  eofflg
  1459.  
  1460. C uses A6 fmt
  1461. C 'day' is in format
  1462.       real*8 daylist(7)
  1463.       character*9 mthlist(12)
  1464.  
  1465.       character*22 dupl
  1466. C only 3:22 used
  1467.       INTEGER*1 dupb(22)
  1468.       Integer*4  iscnds
  1469.       equivalence (line, ln1), (apstr, appnt),(apstr, ap1),
  1470.      1  (dupl, dupb)
  1471.       character*1 blotc
  1472.       equivalence(blot,blotc)
  1473.       Equivalence (ln1,ln1c)
  1474.        include stmtfuncsp.for
  1475.        data blotc/'_'/
  1476.         include comdtcd.inc
  1477.         include escdtcd.inc
  1478.  
  1479.       Data daylist / '   Sun', '   Mon', '  Tues',
  1480.      1 'Wednes', ' Thurs', '   Fri', ' Satur' /
  1481.       Data mthlist
  1482.      1 /'  January', ' February', '    March', '    April',
  1483.      2  '      May', '     June', '     July', '   August',
  1484.      3  'September', '  October', ' November', ' December'/
  1485.  
  1486.  
  1487.       include stmtfunc.for
  1488.  
  1489. c       Initialize:
  1490.  
  1491.       dupl = '##'
  1492. C Init for duplicate check
  1493.  
  1494. c leave = or *
  1495.       if ((ln1 .and. ucmask) .eq. ichar('D'))
  1496.      1    call shrink(1, ifnb, lnb)
  1497.  
  1498.       call dtcdatcvt(3)
  1499. C Pick off a date value
  1500.  
  1501.       im=idmo
  1502.       id=iddy
  1503.       iye=ibigyr
  1504.       call dtcalcdow (isx, imx, im, iye)
  1505. C Get day-of-week for B/O/M
  1506.  
  1507.       idx = mod (id + isx - 2, 7) + 1
  1508. C Calc current d/o/w
  1509.  
  1510.       call dtcidate(imr, idr, iyr)
  1511. C Get today's date
  1512.  
  1513. C if current = today,
  1514. C flag current time
  1515.       if ((im .eq. imr) .and.
  1516.      1   (id .eq. idr) .and.
  1517.      2   (iye .eq. iyr)) then
  1518. C Displaying current day
  1519.           Call time(iscnds)
  1520.           scnds=iscnds
  1521.           scnds = amax1(scnds, 28801.)
  1522. C Get current time (>8 AM)
  1523.           ihalf = mod(ifix(scnds/1800.), 48)
  1524. C current half-hour (orig 0)
  1525.           ihour = ihalf/2
  1526. C       Current hour
  1527.           ihalf = ihalf - (ihour*2)
  1528. C       0 or 1 for half-hour
  1529.  
  1530.        else
  1531.           ihour = 0
  1532. C       Set non-match value
  1533.       endif
  1534.  
  1535. c ************************** Move the cursor to top of screen and clear it,
  1536. c ************************** set up appointments display:
  1537.       write(*,4) esc,homescrn, esc,clrscrn
  1538.  4      format($, 4a, $)
  1539.  
  1540.       write(*,5,err=598) 
  1541.      1 daylist(idx), mthlist(im), id, ibigyr
  1542.  5      format(1x,'Schedule - ', a6,'day, ', a9, i3, ',', i5)
  1543. c      write(*,5) ' ', esc,dhdw2,
  1544. c     1 daylist(idx), mthlist(im), id, ibigyr
  1545. 598     continue
  1546.  
  1547.       Do (i=8,16)
  1548.           If ( i .gt. 12 ) then
  1549.         j = i - 12
  1550.           Else
  1551.         j = i
  1552.           End If
  1553.  
  1554.           if (i .ne. ihour) then
  1555. C Check for highlighting
  1556.         write(*,6) j
  1557.         write(*,7) j
  1558.           else
  1559. C must be current hour
  1560.         if (ihalf .eq. 0) then
  1561. C Check which half
  1562.             write(*,96) esc,revattr, j, esc,resetvattr
  1563.             write(*,7) j
  1564.         else
  1565.             write(*,6) j
  1566.             write(*,97) esc,revattr, j, esc,resetvattr
  1567.         endif
  1568.  
  1569.           endif
  1570.       end do
  1571.  
  1572.  6      format(1x,i2,':00   -')
  1573.  7      format(1x,i2,':30   -')
  1574.  96     format (2x, 2a, i2,':00', 2a, '   -')
  1575.  97     format (2x, 2a, i2,':30', 2a, '   -')
  1576.  
  1577.       if (ihour .ge. 17) then
  1578. C Highlight 'Evening' line
  1579.           write(*,98) esc, esc
  1580.       else
  1581. C Includes display other than today
  1582.           write(*,9)
  1583.       end if
  1584.  
  1585.  9      format(1x, 'Evening -', /, x, 75('='))
  1586.  98     format(1x, a, '[7m Evening', a, '[0m-', /, x, 75('='))
  1587.  
  1588. c ******************* Screen has now been displayed,
  1589. c ******************* now check rest of line for time and appointment
  1590.  
  1591.       if (ln1 .ne. 0) then
  1592. C More characters available?
  1593.  
  1594.           iht = 80
  1595. C Default is 8:00
  1596.           ihmx = iht
  1597. C (only 1 entry)
  1598.           call dtctimcvt(iht, ihmx)
  1599. C Decode time value if present
  1600.  
  1601.           ihh1 = (iht+2)/5
  1602. C Adds 1 if trailing 3
  1603.           ihh2 = (ihmx+2)/5
  1604. C Result is 16 to 35
  1605.           idmx = min0(max0(ihh2-ihh1, 1), 20)
  1606. C 8:00>6:00
  1607.           iht = min0(iht,173)
  1608. C Limit entry time (DTCTIMCVT lim is 180)
  1609.  
  1610. c Note: range of h1:00>h1:30 is considered only one scheduling interval,
  1611. c similarly h(1)>h(2) is an even number, ending just before h(2),
  1612. c computation forces at least one for interval h1:00>h1:00
  1613.  
  1614.           ifnb = 0
  1615.           lnb = 0
  1616.           ivx = 0
  1617.           ap1 = 0
  1618. C Clear appointment string
  1619.  
  1620.           do (i = 1, icmln)
  1621.  
  1622.         ll = line(i)
  1623.         appnt(i) = ll
  1624.  
  1625.         if (ll .eq. 0) go to 6789
  1626. C done
  1627.  
  1628.         ivx = i
  1629. C Save current length
  1630.  
  1631.           end do
  1632.  
  1633. c               Was there an appointment string input?
  1634. c               If so, put it in file, and display it on screen.
  1635. c               If not, move cursor to correct time on screen,
  1636. c               then input the appointment, put in file and re-display it.
  1637.  
  1638.  6789       If (ap1 .eq. 0) then
  1639. C Empty appointment string
  1640.  
  1641.         iy = ihh1 - 13
  1642. C Vertical position for half hour
  1643. c amiga fixup ... iy is 1 less
  1644.         iy = iy-1
  1645. c end amiga fixup...
  1646.         ix = 11
  1647.         call dtcat(ix,iy)
  1648.         ibsp=8
  1649.         write(*, 987) blot,ibsp
  1650. C write blot, backspace
  1651.  987            format ($, 2a1, $)
  1652.         read(*,13,END=914,err=914) workstr
  1653.  13             format(a)
  1654.       do 305 nnn=1,80
  1655.       lapp=81-nnn
  1656.       if(workstr(lapp:lapp).gt.char(32))goto 306
  1657.       workstr(laPP:LAPP)=char(0)
  1658. 305   continue
  1659. 306   continue
  1660. c copy appointment for use later...
  1661.  
  1662.         ifnb = 0
  1663.         lnb = 0
  1664.         ivx = 0
  1665.  
  1666.         Do (i = 1, lapp)
  1667.  
  1668.             ll = work(i)
  1669. C fetch character
  1670.  
  1671.             if (ll .gt. 32) then
  1672.                 if (ifnb .eq. 0) ifnb = i
  1673. C Flag first non-blank
  1674.                 lnb = i
  1675. C Flag last non-blank
  1676.  
  1677.             end if
  1678.  
  1679.             if (ifnb .ne. 0) then
  1680. C Copy after first n/b
  1681.                 ivx = ivx + 1
  1682.                 appnt(ivx) = ll
  1683.             end if
  1684.  
  1685.         end do
  1686.  
  1687.         if (ifnb .eq. 0) go to 914
  1688. C Nothing on read either
  1689.  
  1690.           End If
  1691.  
  1692.           ivx = min0(ivx, iaptlim)
  1693. C ivx = length of string
  1694.  
  1695. C  If we are using the 'S' command, add meetings to the indirected files ONLY,
  1696. C  not to the current (control) file.
  1697.  
  1698.           if (ctlfg .ne. 1) then
  1699. C Add appointment if D or G
  1700.  
  1701.         close (1)
  1702. C Insurance
  1703.         Open ( unit=1,file=FNc(1:fnsz)
  1704.      1  ,status='UNKNOWN',form='FORMATTED',
  1705.      1  position='append',err=9876)
  1706.  
  1707.         ihtxx=iht
  1708.         do (ixx = 1, idmx)
  1709.  
  1710.             write(1,14,err=597) iye,im,id,ihtxx,apstr(1:ivx)
  1711. 597    Continue
  1712.             if ((ihtxx/10)*10 .eq. ihtxx)
  1713.      1        then
  1714.  
  1715.                 ihtxx=ihtxx+3
  1716. C IHT is even hour, go to next half hour
  1717.  
  1718.               else
  1719.  
  1720.                 ihtxx=ihtxx+7
  1721. C IHT is a half hour ... make up to next hour
  1722.  
  1723.             end if
  1724.  
  1725.         end do
  1726.  
  1727.  14             format(i4.4,2i2.2,i3.3,x,a)
  1728.  
  1729.  9876           close(1)
  1730.  
  1731.           End If
  1732.  
  1733.       else
  1734. C Empty line (no appointment to add)
  1735.  914        idmx = 0
  1736. C Use as flag for display only
  1737.  
  1738.       end if
  1739.  
  1740.       eofflg = -1
  1741. C Request OPEN
  1742.       prveof = 0
  1743. C Set for DO WHILE
  1744.  
  1745.       lookind = 0
  1746.       if (ctlfg .ne. 0) lookind = 1
  1747. C Set for looking at filenames
  1748.  
  1749.       irqhash(1) = ihymd(iye, im, id)
  1750. C Set match for file scan
  1751.       irqhash(2) = irqhash(1)
  1752. C One day only
  1753.       IHTsav=IHT
  1754. c Iht clobbered by dtcrdappt
  1755.       do while (prveof .ge. 0)
  1756.  
  1757.          call dtcrdappt(eofflg, lookind)
  1758.  
  1759.           if (eofflg .eq. 1)
  1760.      1     then
  1761. C Returned with filename string
  1762.  
  1763. c on scheduling multiple dates via S or G functions, use this occasion to
  1764. c add the record to everyone's calendar file.
  1765.  
  1766.         close(2)
  1767.         Do (nnn=1,90)
  1768.         nnm=101-nnn
  1769.         If(Workstr(nnm:nnm).ge.char(32))Goto 963
  1770. c find last nonblank char in string
  1771.         End Do
  1772. 963     Continue
  1773.         Open (unit=2, file=workstr(istart:nnm), status='UNKNOWN',
  1774.      1      form='FORMATTED',
  1775.      2      position='APPEND', err=1119)
  1776.  
  1777. c        ihtxx=iht
  1778.         ihtxx=ihtsav
  1779.         do (ixx = 1, idmx)
  1780.             write(2,14,err=596)iye,im,id,ihtxx,apstr(1:ivx)
  1781. 596     Continue
  1782.             if ((ihtxx/10)*10 .eq. ihtxx) then
  1783.                 ihtxx=ihtxx+3
  1784. C iht is an even hour ... add the half hour
  1785.             else
  1786.                 ihtxx=ihtxx+7
  1787. C iht is a half hour ... make up to next hour
  1788.             end if
  1789.  
  1790.         end do
  1791.  
  1792.  1119           close(2)
  1793.  
  1794. c Display appointment if it matches current date
  1795.  
  1796.           else If (eofflg .eq. 0)
  1797.      1     then
  1798.  
  1799.         iy = min0(max0((((iht+2) / 5) - 13), 3), 22)
  1800.  
  1801. c  Amiga fixup -- iy is 1 less
  1802.         iy=iy-1
  1803. c end Amiga fixup
  1804.  
  1805. C Compute vertical posn
  1806. C Have we been here before
  1807.         if (dupb(iy) .eq. 32)
  1808.      1    then
  1809. C No
  1810.             dupb(iy) = '-'
  1811. C Flag it
  1812.           else
  1813. C Duplicate time stamps, find substitute
  1814.             do (ix = iy-1, 3, -1)
  1815. C Search backward first
  1816.                 if (dupb(ix) .eq. 32)
  1817.      1            then
  1818.                     iy = ix
  1819. C Save replacement
  1820.                     dupb(iy) = 'v'
  1821. C Point to where it should go
  1822.                     go to 3141
  1823. C >>> BREAK <<<
  1824.                 end if
  1825.             end do
  1826.             do (ix = iy + 1, 22)
  1827. C Search forward
  1828.                 if (dupb(ix) .eq. 32)
  1829.      1            then
  1830.                     iy = ix
  1831. C Save replacement
  1832.                     dupb(iy) = '^'
  1833. C Point to where it should go
  1834.                     go to 3141
  1835. C >>> BREAK <<<
  1836.                 end if
  1837.             end do
  1838.             dupb(iy) = blot
  1839. C Flag it
  1840.         end if
  1841.  
  1842.  3141           ix = 2
  1843. C first char to print
  1844.         if (appoin(1) .ne. 32)
  1845.      1    then
  1846.             ix = 1
  1847. C '12:00   - Appointment'
  1848.           else
  1849.             if (iaptln .le. 1)
  1850.      1       then
  1851.                 appoin(2) = blot
  1852. C Display BLOT for empty entry
  1853.                 iaptln = 2
  1854.             end if
  1855.         end if
  1856.  
  1857.         kk = min0(iaptln, iaptlim)
  1858.  
  1859.         call dtcat(8,iy)
  1860. C Set cursor position
  1861.  
  1862. C flag + text
  1863.         write(*,300) dupb(iy), ' ', apptstr(ix:kk),
  1864.      1      esc,'[K'
  1865. C Erase EOL
  1866.  300            format($, 5a, $)
  1867.  
  1868.           End If
  1869. C eofflg .ge. 0
  1870.  
  1871.           prveof = eofflg
  1872. C Show what happened
  1873.  
  1874.       end do
  1875. C while (prveof)
  1876.       write(*,367)
  1877. 367    format('  ')
  1878. d      write(4,4203)
  1879. d4203  format(' Day .. returning')
  1880. d      call dely
  1881.       call dtcat(1,22)
  1882.       Return
  1883.       end
  1884. C -h- month.for   Tue Jul  8 16:05:05 1986
  1885. c-----------------------------------------------------------------------
  1886. C       Month-at-a-glance subroutine
  1887. C       part of Mitch Wyle's DTC program
  1888. C       Input:
  1889. c               line    -       72 INTEGER*1 string;  Format: M [dd[19[yy]]]
  1890. C       Output:
  1891. c               display screen (see below)
  1892. C  Line
  1893. c     1 Prevmonth                       Nextmonth
  1894. c     2 SMTWTFS                           SMTWTFS
  1895. C   3-8 Calendar                         Calendar
  1896. c  9/10 Y e a r         M o n t h         Y e a r
  1897. c    11               S M T W T F S
  1898. c 13-23              C a l e n d a r
  1899. C Lines 9/10 are double-height/double-width
  1900. c Odd lines 11-23 are double-width
  1901. c Even lines 10-22 are blank
  1902. C-----------------------------------------------------------------------
  1903. C       Modified 850318, several changes- CG
  1904. c               Display today's date in current, prev or next month
  1905. c                 in reverse video
  1906. c               Write out >>> only <<< non-blank flags (*'s)
  1907. c               Speed-up of month display (actually in dtcdspmth subr)
  1908. c               Months mixed-case and centered (GABY)
  1909. c       Modified 850809 - display IBIGYR both sides of month, DH/DW
  1910.  
  1911.       SUBROUTINE month
  1912. C (line)
  1913.  
  1914. c       Declarations:
  1915.  
  1916.       include comdtc.INC
  1917.       include apptdtc.INC
  1918.       include escdtc.INC
  1919.  
  1920.       INTEGER*1 TEMP
  1921.       Dimension TEMP(4)
  1922. C       temporary string converting array
  1923.       CHARACTER*4 TMPP
  1924.       EQUIVALENCE(TMPP,TEMP(1))
  1925.       Integer*4    id
  1926. C       Julian Day
  1927.       Integer*4  im
  1928. C       Julian Month
  1929.       Integer*4  iy
  1930. C       Julian Year
  1931.  
  1932.       Integer*4  prveof, eofflg
  1933.  
  1934. c string month name
  1935.       INTEGER*1 monthn(9),
  1936.      1 lmonth(9)
  1937. c Entries true if lenght of name is even
  1938.       logical*1 lmneven(12)
  1939. c Entries true if length of name is odd
  1940.       logical*1 lmnodd(12)
  1941.  
  1942.       INTEGER*1 out(79)
  1943. C       The output string and * array
  1944.         INTEGER*1 rchr
  1945. C       Flag set (or reset) character
  1946.       INTEGER*1 ln1
  1947. C       Same as line(1)
  1948.        include stmtfuncsp.for
  1949.       equivalence (line, ln1)
  1950.       Character*41 lxfmt
  1951.       Character*2 lxfixx,lxfixy
  1952.       Character*1 lxfc(41)
  1953.       Equivalence(lxfc(1),lxfmt)
  1954.       Equivalence (lxfixx,lxfc(14)),(lxfixy,lxfc(27))
  1955.       include comdtcd.inc
  1956.       include escdtcd.inc
  1957. c 8      format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $)
  1958. c      write(*,8) ' ', esc,dhdw2, temp, monthn, temp
  1959. c
  1960.       data lxfmt/'(7x,4(a1,2x),01x,9(2x,a1),01x,4(2x,a1),$)'/
  1961.       data lmneven/
  1962.      1 .false., .true., .false., .false., .false., .true.,
  1963.      2  .true., .true., .false., .false., .true.,  .true./
  1964. c Entries true if length of name is odd
  1965.       data lmnodd
  1966.      1 /.true., .false., .true., .true.,  .true., .false.,
  1967.      2 .false., .false., .true., .true., .false., .false./
  1968.  
  1969.       include stmtfunc.for
  1970.  
  1971. c Trim off the M from command line:
  1972.       if(ln1.gt.96)ln1=ln1-32
  1973.       if ((ln1 ) .eq. Ichar('M'))
  1974.      1 call shrink(1, ifnb, lnb)
  1975.  
  1976.       call dtcdatcvt(2)
  1977. C Decode date string
  1978.  
  1979.       im=idmo
  1980. C Pick up result from common
  1981.       id=iddy
  1982.       iy=ibigyr
  1983.  
  1984.       call dtcidate(irm,ird,iry)
  1985. C Real month,day,year, for display highlight
  1986.  
  1987. c Move the cursor to the top part, clear the screen
  1988.  
  1989.       write(*,600) esc,homescrn, esc,clrscrn
  1990.  600    format ($, 4a, $)
  1991.        Call Dtcat(1,1)
  1992. c Now start building the output string: (out)
  1993.  
  1994.       WRITE(TMPP,20,ERR=11)IY
  1995. C       encode(4, 20, temp, err=11) iy
  1996.  11     continue
  1997.  20     format(i4)
  1998.  
  1999. c Calculate nominal prev, next month numbers
  2000.  
  2001.       lm = im - 1
  2002.       ly = iy
  2003.       nm = im + 1
  2004.       ny = iy
  2005.  
  2006.       If ( im .eq. 1 ) then
  2007.  
  2008.           lm = 12
  2009.           ly = iy - 1
  2010.  
  2011.       else If ( im .eq. 12 ) then
  2012.  
  2013.           nm = 1
  2014.           ny = iy + 1
  2015.  
  2016.       End If
  2017.  
  2018. C PRINT PREVIOUS MONTH
  2019.       call dtcmthnam(lm,lmonth)
  2020.  
  2021. C PRINT NEXT MONTH CALENDAR AT TOP
  2022.       call dtcmthnam(nm,monthn)
  2023.  
  2024. C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS
  2025.       ix = 3
  2026.       if (lmneven(lm)) ix = ix + 1
  2027.       call dtcat(ix, 1)
  2028.       write(*,6) lmonth
  2029.       ix = 61
  2030.       if (lmneven(nm)) ix = ix + 1
  2031.       call dtcat(ix, 1)
  2032.       write(*,6) monthn
  2033.  6      format ($, 9(1a1, 1x))
  2034.       call dtcat(1, 2)
  2035.       write(*,7)
  2036.  7      format($,'Su Mo Tu We Th Fr Sa',
  2037.      1  T60,'Su Mo Tu We Th Fr Sa')
  2038. c       call dtcat(35, 7)
  2039. C Center year above cur month
  2040. c       write(*,96) temp
  2041. c 96        format ('$', 4(x, a1))
  2042.  
  2043. c Now display last month, header for this month, and next month:
  2044.  
  2045. c Last month to upper-left corner of screen
  2046.  
  2047.       call dtcalcdow(ib,il,lm,ly)
  2048.       call dtcdspmth(ib,il,0,0,-1,0)
  2049.       If ((irm .eq. lm) .and. (iry .eq. ly)) then
  2050. C today in rev video
  2051.           irdw = mod (ird + ib - 2, 7)
  2052. C Day of week (orig 0)
  2053.           irwk = (ird + ib - 2)/7
  2054. C Week in month (orig 0)
  2055.           call dtcat ((irdw*3) + 2, irwk + 3)
  2056.           write (*,684) esc,revattr, ird, esc,resetvattr
  2057.       end if
  2058.  
  2059. c Next month to upper-right corner of screen
  2060.  
  2061.       call dtcalcdow(ib,il,nm,ny)
  2062.       call dtcdspmth(ib,il,58,0,-1,0)
  2063.       If ((irm .eq. nm) .and. (iry .eq. ny)) then
  2064. C today in rev video
  2065.           irdw = mod (ird + ib - 2, 7)
  2066. C Day of week (orig 0)
  2067.           irwk = (ird +ib - 2)/7
  2068. C Week in month (orig 0)
  2069. c added 1 to x coord in dtcat for amiga fixup here and just above.
  2070.           call dtcat ((irdw*3) + 60, irwk + 3)
  2071.           write (*,684) esc,revattr, ird, esc,resetvattr
  2072.       end if
  2073.  
  2074. c               display big banner header name of this month:
  2075.  
  2076. c       call dtcat(ix,9)
  2077.       call dtcat(1,9)
  2078.  
  2079.       call dtcmthnam(im,monthn)
  2080.  
  2081.       ix = 11
  2082.       if (lmneven(im)) ix = ix + 1
  2083.       ixx = ix - 9
  2084.       ixy = 14 - ix
  2085.       ixx2=ixx+ixx
  2086.       ixy2=ixy+ixy
  2087. c double spaces for single-wide char screen to emulate dbl wide char screen
  2088.        write(lxfixx,2220)ixx2
  2089. 2220   format(i2.2)
  2090.        write(lxfixy,2220)ixy2
  2091.        write(*,lxfmt)temp,monthn,temp
  2092. c       write(*,225)temp
  2093. c 8      format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $)
  2094. c      write(*,8) ' ', esc,dhdw2, temp, monthn, temp
  2095.  
  2096. c Now print the week day headers for this month, and the days for this month:
  2097.  
  2098.       call dtcat(1,11)
  2099.       write(*,10)
  2100.  10     format($,
  2101.      1 '  S u n      M o n     T u e s     W e d s   T h u r s',
  2102.      1 '       F r i       S a t')
  2103. c          x     x     x     x     x     x     x     x
  2104.  
  2105. C Mark double-width lines
  2106. c      write (*,138)
  2107. c     1 esc,'[13H', esc,dwide,
  2108. c     2 esc,'[15H', esc,dwide,
  2109. c     3 esc,'[17H', esc,dwide,
  2110. c     4 esc,'[19H', esc,dwide,
  2111. c     5 esc,'[21H', esc,dwide,
  2112. c     6 esc,'[23H', esc,dwide
  2113.  138    format ($, 24a, $)
  2114. c
  2115.         call dtcalcdow(ib,il,im,iy)
  2116.         call dtcdspmth(ib,il,8,8,9,1)
  2117. C For single-width
  2118. c        call dtcdspmth(ib,il,1,3,9,1)
  2119. C For double-width
  2120. c
  2121.         If ((irm .eq. im) .and. (iry .eq. iy)) then
  2122. C today in rev video
  2123. c
  2124.           irdw = mod (ird + ib - 2, 7)
  2125. C Day of week (orig 0)
  2126.           irwk = (ird + ib - 2)/7
  2127. C Week in month (orig 0)
  2128.           call dtcat ((irdw*11)+9, (irwk*2)+13)
  2129.  
  2130.           if (id .eq. ird) then
  2131.         write (*,684) esc,'[4;7m', ird, esc,resetvattr
  2132.           else
  2133.         write (*,684) esc,revattr, ird, esc,resetvattr
  2134.         go to 685
  2135. C And show looking-at date
  2136.           end if
  2137.  
  2138.  684            format($, 2a, i2, 2a, $)
  2139.  
  2140.        else
  2141.  
  2142.  685        irdw = mod (id + ib - 2, 7)
  2143. C Day of week (orig 0)
  2144.           irwk = (id + ib - 2)/7
  2145. C Week in month (orig 0)
  2146.           call dtcat ((irdw*11)+9, (irwk*2)+13)
  2147.  
  2148.           write (*,684) esc,'[4m', id, esc,resetvattr
  2149.  
  2150.       end if
  2151.  
  2152.       if (rdspfg .eq. 0) then
  2153.         rchr='*'
  2154.         out(1) = ' '
  2155.       else
  2156.         rchr=' '
  2157.         out(1) = '*'
  2158.       end if
  2159.  
  2160.       Do (i= 2, 31)
  2161. C set the out array to all blanks:
  2162.       out(i) = out(1)
  2163.       end do
  2164.  
  2165. c Now for files I/O to put *'s on days with appointments:
  2166.  
  2167.       irqhash(1) = ihymd(iy, im, 1)
  2168. C Want entries for
  2169.       irqhash(2) = ihymd(iy, im, 31)
  2170. C current month
  2171.  
  2172.       eofflg = -1
  2173.       prveof = 0
  2174.  
  2175.       do while (prveof .ge. 0)
  2176.  
  2177.           call dtcrdappt(eofflg, 0)
  2178.           if (eofflg .ge. 0) out(ihd) = rchr
  2179.           prveof = eofflg
  2180.  
  2181.       end do
  2182.  
  2183. c Have now accumulated all info about current month,
  2184. c go back and flag appropriate days
  2185.  
  2186.       iy = 13
  2187.       ip = ib - 1
  2188.  
  2189.       Do (i=1,il)
  2190.  
  2191.           ip = ip + 1
  2192. C       increment day number
  2193.           If ( ip .gt. 7 ) then
  2194. C       is it Sunday again?
  2195.         ip = 1
  2196. C       reset day to Sunday.
  2197.         iy = iy + 2
  2198. C       move down one line
  2199.           End If
  2200.  
  2201.           if (out(i) .ne. 32) then
  2202. C Write only non-blank entries
  2203. C
  2204.                ix = 11 * ip - 4
  2205. c        ix = 6 * ip - 5
  2206.         call dtcat(ix,iy)
  2207. C       position cursor
  2208.         write(*,231) out(i)
  2209. C       write * to screen
  2210.  231            format($,a1, $)
  2211.           end if
  2212.       end do
  2213. C # days in month
  2214.  
  2215.  999    call dtcat(1,23)
  2216. C Position for next prompt
  2217.  
  2218.       end
  2219. C -h- fnscan.for  Tue Jul  8 16:05:30 1986
  2220. c subroutine FNSCAN - scan file-name record (999999999x<filespec>=)
  2221. c and strip space, mark 0 at end of name
  2222.  
  2223.       subroutine fnscan(work, maxlen, iwkln, ijr)
  2224.  
  2225.       INTEGER*1 work(maxlen)
  2226.  
  2227.       INTEGER*1 ll
  2228.  
  2229.       ij = 0
  2230. C Initialize output index
  2231.       do (ii=1, min0(iwkln, maxlen))
  2232. C Start loop
  2233.           ll = work(ii)
  2234. C Get input character
  2235.           if (ll .gt. 32) then
  2236. C Strip all spaces & ctls
  2237.         if (ll .eq. ichar('=')) go to 10
  2238. C '=' marks end
  2239.         ij = ij + 1
  2240. C Character accepted
  2241.         work(ij) = ll
  2242. C Copy it
  2243.           end if
  2244. C (graphic character)
  2245.       end do
  2246. C Loop
  2247.  
  2248.  10     work(min0(ij+1,maxlen)) = 0
  2249. C Set marker for OPEN
  2250.  
  2251.       ijr = ij
  2252. C Return length of string
  2253.  
  2254.       end
  2255. C -h- week.for    Tue Jul  8 16:05:58 1986
  2256. c-----------------------------------------------------------------------
  2257. C       Week-at-a-glance subroutine
  2258. C       part of Mitch Wyle's DTC program
  2259. C       Input:
  2260. c               line    -       72 INTEGER*1 string;  Format: W [mmddyy]
  2261. C       Output:
  2262. c               display screen (see below)
  2263. C-----------------------------------------------------------------------
  2264. C       Modified 850117 to fix leap-year problems - CG
  2265. c       Modified 850314 to use real corners, lines and T's for box - CG
  2266. c       Modified 850318 to display current date in reverse video - CG
  2267. c       Modified 850806 to use new subroutines (including DTCRDAPPT)
  2268. c               and get rid of previously commented-out code
  2269. c
  2270.       SUBROUTINE week
  2271. C (line)
  2272. C       Declarations:
  2273. c
  2274.       include comdtc.INC
  2275.       include apptdtc.INC
  2276.       include escdtc.INC
  2277. c
  2278.       INTEGER*1 ln1, ll
  2279. C       equiv to input line
  2280.       INTEGER*1 temp(2)
  2281. C       temporary string converting array
  2282.       logical apts(7,19), aptsln(133), tflg
  2283.       Integer*4  prveof, eofflg
  2284.       Integer*4  HASH
  2285.       Integer*4    id
  2286. C       Julian Day
  2287.       Integer*4  im
  2288. C       Julian Month
  2289.       Integer*4  iy, iyd
  2290. C       Julian Year
  2291.  
  2292. c lengths of months ... leap years adjusted in code
  2293. c December Jan ... Dec Jan
  2294.       Integer*4  ml(14)
  2295.         include stmtfuncsp.for
  2296.       equivalence (line, ln1), (apts, aptsln)
  2297.        include comdtcd.inc
  2298.        include escdtcd.inc
  2299.       Data ml
  2300.      1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/
  2301.  
  2302.       include stmtfunc.for
  2303.  
  2304. c       Initialize:
  2305.  
  2306.       iss = z'7FFFFFFF'
  2307. C Impossible saved Sunday day...
  2308.       iwf=0
  2309. C Adjustment factor
  2310.  
  2311.       if ((ln1 .and. ucmask) .eq. Ichar('W'))
  2312.      1 call shrink(1, ifnb, lnb)
  2313.  
  2314.       call dtcidate(imx,idx,iyx)
  2315. C       initialize to today's date
  2316.  
  2317.       call dtcdatcvt(3)
  2318. C       Get date string
  2319.  
  2320.       im=idmo
  2321. C       Copy values
  2322.       id=iddy
  2323.       iy=ibigyr
  2324.  
  2325.       if (islpyr(iy)) then
  2326.         ml(3)=29
  2327. C Feb is in ML(3), not ML(2)
  2328. C
  2329.           else
  2330.         ml(3)=28
  2331. C C Garman, 17-Jan-1985
  2332.       end if
  2333.  
  2334. C Where we look for free space of n units or more length,
  2335. C then just display reverse and zot out all shorter periods
  2336.  
  2337.       if (ctlfg .eq. 1) rdspfg=1
  2338.       tflg = (rdspfg .ne. 0)
  2339. C initialize flag
  2340.       do (ij = 1, 7*19)
  2341.           aptsln(ij) = tflg
  2342.       end do
  2343.  
  2344.       if (ctlfg .ne. 0) then
  2345. C Locate N
  2346.  
  2347.           intsz = 0
  2348.           i = 1
  2349.           do while(numeric(line(i)))
  2350.         intsz = (intsz * 10) + icvtbn1(line(i))
  2351.         i = i + 1
  2352.         if (i .gt. icmln) go to 1191
  2353.           end do
  2354.  
  2355. c clamp interval size to permissible range...
  2356.  
  2357.  1191       intsz = min0(max0(intsz, 1), 18)
  2358.  
  2359.        end if
  2360. C               Paint the screen:
  2361. c
  2362.  
  2363. c following sequence moves to upper left corner on VT100 compatible terminals
  2364. c and clears screen
  2365.  
  2366.       write(*,6) esc,homescrn, esc,clrscrn
  2367.  6      format(1x,4a,$)
  2368.         call dtcat(1,1)
  2369. c Now write box, in graphics mode, to enclose days of week
  2370.  
  2371.       write (*, 70)  '+', '+'
  2372. C Upper corners & top line
  2373. c
  2374.       irow=2
  2375.       Do (i = 1, 6)
  2376. C 6 more days' worth
  2377.       Call DtcAt(1,irow)
  2378.       irow=irow+1
  2379.           write (*, 71)
  2380.       Call DtcAt(1,irow)
  2381.       irow=irow+1
  2382.           write (*, 71)
  2383.       Call DtcAt(1,irow)
  2384.       irow=irow+1
  2385.           write (*, 72) 
  2386.       end do
  2387. c
  2388.       Call DtcAt(1,irow)
  2389.       irow=irow+1
  2390.       write (*, 71) 
  2391.       Call DtcAt(1,irow)
  2392.       irow=irow+1
  2393.       write (*, 71) 
  2394. C two more sides
  2395.       Call DtcAt(1,irow)
  2396.       irow=irow+1
  2397.       write (*, 73)  '+', '+'
  2398. C Lower corners & bottom line
  2399. c
  2400.  70     format (x, 1a1, 74('-'), 1a1)
  2401. C Upper/lower corners
  2402. C sides
  2403.  71     format (x,  '|', 74(' '), '|')
  2404.  72     format (x,  '+', 74('-'), '+')
  2405. C interior lines
  2406.  73     format (x, 1a1, 74('-'), 1a1)
  2407. C Upper/lower corne1rs
  2408.  
  2409.       call dtcat(2,2)
  2410.       write(*,10) '   Sunday'
  2411.  10     format($,a)
  2412.       call dtcat(2,5)
  2413.       write(*,10) '   Monday'
  2414.       call dtcat(2,8)
  2415.       write(*,10) '  Tuesday'
  2416.       call dtcat(2,11)
  2417.       write(*,10) 'Wednesday'
  2418.       call dtcat(2,14)
  2419.       write(*,10) ' Thursday'
  2420.       call dtcat(2,17)
  2421.       write(*,10) '   Friday'
  2422.       call dtcat(2,20)
  2423.       write(*,10) ' Saturday'
  2424.  
  2425. C       Now figure out which Sunday is closest to the day specified by id:
  2426. c
  2427.  
  2428.       call dtcalcdow(ib,il,im,iy)
  2429. C Remember: ib = 1st day of month
  2430.  
  2431. c il = length of month
  2432. c ib = day number of 1st day of month, 1=sunday.
  2433.  
  2434.       if ( ib .eq. 1 ) then
  2435.           is = 1
  2436. C IS is the Sunday we want.  It is
  2437.       else
  2438. C either the 1st day of the month
  2439.           is = 9 - ib
  2440. C or 9 - 1st day of month.
  2441.       end if
  2442.  
  2443. C Now...Sunday may be in preceding month
  2444.  11     continue
  2445. C If the day is not in the 1st week
  2446. c try to fix up case of wrong sunday..
  2447. c ML array is preceding month's length
  2448.       iwf=0
  2449.       if (id .lt. is) then
  2450.         is=is-7+ml(im)
  2451.         im=im-1
  2452.         if (im .le. 0) then
  2453. c adjust year wrapback
  2454.                 im=12
  2455.                 iy=iy-1
  2456.         end if
  2457.         il=ml(im+1)
  2458.         iwf=-il
  2459.         go to 301
  2460.       end if
  2461.       if ( ( id - is ) .ge. 7 ) then
  2462. C of the month, then keep adding
  2463.           is = is + 7
  2464. C 7 until we get to the week we
  2465.           go to 11
  2466. C want.
  2467.       end if
  2468.  301    continue
  2469. c since we can wrap months down as well as up construct date limits here...
  2470. c ***   if (iy .gt. 1900) iy=iy-1900
  2471. c just generate a hashcode that is strictly increasing as a function of
  2472. c date. only purpose is to be monotonic increasing, so continuity is
  2473. c not important. we use other methods to handle exact offsets. note that
  2474. c where wrap arounds occur, iss is allowed to be a little larger than
  2475. c real month length or a small negative where used below...not here.
  2476.  
  2477.       irqhash(1) = ihymd(iy, im, is)
  2478.       iss = is
  2479. C don't lose track of Sunday's date.
  2480.       issss = is
  2481. C It will be important later...
  2482. C       Now figure out where to write the dates of the days of the week,
  2483. c       and write em out where they belong:
  2484. c
  2485.       iyd = mod(iy, 100)
  2486. C Display two digits
  2487.  
  2488.       Do (i=1,7)
  2489.           jy = 3 * i
  2490.           call dtcat(2,jy)
  2491.           if ((im .eq. imx) .and. (iy .eq. iyx)) then
  2492.         if (is .eq. idx) then
  2493.             if (id .eq. idx) then
  2494. C reverse + underline
  2495.                 write(*,130,err=99)
  2496.      1              esc,'[4;7m', im,is,iyd, esc,resetvattr
  2497.             else
  2498. C reverse only
  2499.                 write(*,130,err=99)
  2500.      1              esc,revattr, im,is,iyd, esc,resetvattr
  2501.             end if
  2502.         else
  2503.             go to 684
  2504.         end if
  2505.           else
  2506.  684            if (is .eq. id) then
  2507. C underline only
  2508.             write(*,130,err=99)
  2509.      1          esc,'[4m', im,is,iyd, esc,resetvattr
  2510.         else
  2511. C N/O/T/A, nothing fancy
  2512.             write(*,13,err=99) im,is,iyd
  2513.         end if
  2514.           end if
  2515.  
  2516.  99         is = is + 1
  2517.           If ( is .gt. il ) then
  2518. C Did the month change
  2519.         is = 1
  2520. C during this week?
  2521.         im = im + 1
  2522.         If ( im .gt. 12 ) then
  2523. C Did the year change
  2524.             im = 1
  2525. C during this week?
  2526.             iy = iy + 1
  2527.             iyd = mod(iy, 100)
  2528.         End If
  2529.           End If
  2530.  
  2531.       irqhash(2) = ihymd(iy, im, is)
  2532. C save last day value in hash
  2533.  
  2534.       end do
  2535.  
  2536.  13     format($, i3, '/', i2.2,'/',i2.2)
  2537.  130    format($, a1, a, i3, '/', i2.2,'/',i2.2, a1, a)
  2538.  
  2539. C               Now for Files I/O:
  2540. c
  2541.  
  2542. c       Set up a boolean array of appointment times and days of
  2543. c       the week.  Notice that if this program were written in
  2544. c       assembler, we would use only 18 INTEGER*1s and store this
  2545. c       information by bits instead of INTEGER*1s.  Oh well.  There
  2546. c       goes 100 INTEGER*1s of storage space...
  2547. c       When life confronts you with its troubles and woes,
  2548. c       Have no fear, just fire photon torpedos
  2549. C
  2550.  
  2551. C       Read the appointments; If the appointment is for one of
  2552. c       the days in this week, mark that spot in the appointments
  2553. c       array true.  Otherwise that coordinate is false.  The array
  2554. c       looks like this:
  2555. C               Su Mo Tu We Th Fr Sa
  2556. C       8:00     T  F  F  F  F  F  F
  2557. C Appointment on Su at 8:00
  2558. c       8:30     F  T  T  T  F  F  F
  2559. C Appointments on Mo, Tu, We at 8:30
  2560. c       9:00     F  F  F  F  F  F  F
  2561. C No appointments at 9:00 this week
  2562. c       9:30
  2563. C        .       .  .  .  .  .  .  .
  2564. c        .       .  .  .  .  .  .  .            etcetera
  2565. c        .       .  .  .  .  .  .  .
  2566. c
  2567. C sic itur ad astra
  2568. C       Etcetra.  Caveat emptor and three other latin words.
  2569. C
  2570.       prveof = 0
  2571.       eofflg = -1
  2572.  
  2573.       do while (prveof .ge. 0)
  2574.  
  2575.           call dtcrdappt(eofflg, 0)
  2576. C Look at appointments file
  2577.  
  2578.           if (eofflg .ge. 0)
  2579.      1     then
  2580.  
  2581. C NOW we are testing the date range validly. However, we must adjust
  2582. C the ISS range to be in the range from - (small #) to +
  2583. C (or some such) to take into account the fact that it MUST be
  2584. C continuous in order to be transformed into a cursor address.
  2585. C FORTUNATELY we saved the appropriate length of month adjustment
  2586. C above so can add it back in here.  IWF=0 most times.
  2587.  
  2588.         iss=issss+iwf
  2589.         jx = ihd - iss + 1
  2590. C need a little more logic to handle crossing months here
  2591. c where jx >7 we have to adjust by length of month once more...
  2592.         if (jx .gt. 7) jx=jx+iwf
  2593. c also have to handle cases where we crossed months, by adding in
  2594. c length of previous month.
  2595.         if (jx .le. 0) jx=jx+ml(im)
  2596.         jy = min0(max0(((iht+2)/5)-15, 1), 19)
  2597.  
  2598.         if ((jx .ge. 1) .and. (jx .le. 7) .and.
  2599.      1      (jy .ge. 1) .and. (jy .le. 19))
  2600.      2    then
  2601.  
  2602.             apts(jx,jy) = .not. tflg
  2603. C Derived a long time ago
  2604. C
  2605.  
  2606.        end if
  2607.  
  2608.           end if
  2609.  
  2610.           prveof = eofflg
  2611.  
  2612.       end do
  2613. C while
  2614. C               Now display the information we have extracted:
  2615. c
  2616.       if (ctlfg .ne. 0) then
  2617. c here go through and look for "intsz" sized intervals and
  2618. c set apts(i,j) to .false. if the interval is too small...
  2619.           k=19-intsz
  2620.           Do (i=1,7)
  2621.         Do (j=1,k)
  2622.             ivl=1
  2623.             Do (l=1,intsz)
  2624.                 if (.not. apts(i,j+l-1)) ivl=0
  2625.             end do
  2626.             if (ivl .ne. 1) apts(i,j)= .false.
  2627.         end do
  2628. c since we are showing valid start times, set all times at the end of
  2629. c the day false since they can't possibly be valid times for any
  2630. c meetings.
  2631.         kk=k+1
  2632.         if (kk .le. 18) then
  2633.             do (j=kk,18)
  2634.                 apts(i,j)= .false.
  2635.             end do
  2636.         end if
  2637.           end do
  2638.       End If
  2639.  
  2640.       Do (i=1,7)
  2641. C Go through the entire
  2642.           Do (j=1,19)
  2643. C array and display
  2644.         If ( apts(i,j) ) then
  2645. C appts if they exist:
  2646.             jx = 6 * j + 10
  2647. C jx is x coord of cursor
  2648.             jy = 3 * i - 1
  2649. C jy is y coord of cursor
  2650.  
  2651.             If ( jx .gt. 74) then
  2652. C For afternoon and evening
  2653.                 jy = jy + 1
  2654. C appointments, put the
  2655.                 jx = jx - 63
  2656. C appointments on the second
  2657.             End If
  2658. C line of the day
  2659.  
  2660.             jj = j
  2661. C Now decode the time again
  2662.             call dtcat(jx,jy)
  2663. C to display.  jj is time
  2664.             if (((j/2)*2) .ne. j) then
  2665. C of appointment
  2666.                 jj = jj + 7 - (jj/2)
  2667. C If the time is odd then
  2668.                 write(*,16) jj
  2669. C it falls on the hour.
  2670.  16                     format($,i2,':00')
  2671.             else
  2672.                 jj = jj + 7 - (jj/2)
  2673. C If the time is even then
  2674.                 write(*,17) jj
  2675. C it falls on the half hour
  2676.  17                     format($,i2,':30')
  2677.             end if
  2678.         End If
  2679.           end do
  2680.       end do
  2681.  
  2682.  999    call dtcat(1,22)
  2683. C move cursor to the bottom
  2684.       end
  2685. C of the screen and return
  2686. C -h- year.for    Tue Jul  8 16:06:21 1986
  2687. c-----------------------------------------------------------------------
  2688. C       Year-at-a-glance subroutine
  2689. C       part of Mitch Wyle's DTC program
  2690. C       Input:
  2691. c               line    -       72 INTEGER*1 string;  Format: Y [yy]
  2692. C       Output:
  2693. c               display screen (see below)
  2694. C-----------------------------------------------------------------------
  2695. c
  2696.  
  2697.       SUBROUTINE year
  2698. C (line)
  2699.  
  2700. c Declarations:
  2701.  
  2702.       include comdtc.INC
  2703.       include escdtc.INC
  2704.  
  2705.       INTEGER*1 temp(4), ln1
  2706.       Character*4 tempc
  2707.       Equivalence(tempc,temp(1))
  2708.       Character*2 tempc2
  2709.       Equivalence(tempc2,temp(1))
  2710. C       temporary string converting array
  2711.  
  2712.       Integer*4    id, idr
  2713. C       Julian Day
  2714.       Integer*4 im, imr
  2715. C       Julian Month
  2716.       Integer*4 iye, iyr
  2717. C       Julian Year
  2718.       Integer*4 iyo
  2719. C       y offset for where to put month data
  2720.       Integer*4   ix
  2721. C       x coord of cursor
  2722.       Integer*4 iy
  2723. C       y coord of cursor
  2724.       Integer*4   img
  2725. C       month loop index goes from 1 to 12
  2726.       Integer*4   jg
  2727. C       index offset defined by img
  2728.       Integer*4 ii
  2729. C       implied do loop index variable
  2730.       INTEGER*1 monthn(9)
  2731. C       string month name
  2732.       real badf77
  2733.       real badftn
  2734. C       Maybe error in array subscripts
  2735. c string containing names of days of week
  2736.       character*21 wknam
  2737. C       Hoolay kan
  2738.       INTEGER*1 ihold
  2739. C       hold the screen
  2740.  
  2741. c Entries true if length of name is even
  2742.       logical*1 lmneven(12)
  2743.  
  2744.       equivalence (line, ln1)
  2745.        include comdtcd.inc
  2746.        include escdtcd.inc
  2747.       Data wknam
  2748.      1 / 'Su Mo Tu We Th Fr Sa|'/
  2749.       Data lmneven/
  2750.      1 .false., .true., .false., .false., .false., .true.,
  2751.      2  .true., .true., .false., .false., .true.,  .true./
  2752.  
  2753.  
  2754.       if ((ln1 .and. ucmask) .eq. ichar('Y'))
  2755.      1 call shrink(1, ifnb, lnb)
  2756.  
  2757.       call dtcdatcvt(1)
  2758. C       Parse out a year value
  2759.  
  2760.       im=idmo
  2761.       id=iddy
  2762.       iye=ibigyr
  2763. c
  2764.       call dtcidate(imr,idr,iyr)
  2765. C       initialize to today's date
  2766.  
  2767. C       to display in reverse video
  2768.  
  2769. c set screen to 132 col, double width for 
  2770.     write(*,300) esc,'[0;0H',esc,'[1J'
  2771. C Erase screen first in this mode...
  2772.       write(*,300) esc,'[?3h',
  2773.      1 esc,'[2H', esc,'#6',
  2774.      2 esc,'[14H', esc,'#6'
  2775. C Month headers
  2776.       Write(tempc,20,err=97)iye
  2777. c      encode (4, 20, temp, err=97) iye
  2778.  20     format(i4)
  2779.  
  2780.  97     ix = 29
  2781.       iy = 11
  2782.       call dtcat(ix,iy)
  2783. C Display year in
  2784.       write(*,305) esc,dhdw1, temp
  2785. C double height/double width
  2786. c *******&&&& ??????
  2787. C in the middle of the screen
  2788.       iy = 12
  2789.       call dtcat(ix,iy)
  2790.       write(*,305) esc,dhdw2, temp
  2791. C second line
  2792.  
  2793.  99     Do 4 img = 1,12
  2794. C       for each month:
  2795.           call dtcmthnam(img,monthn)
  2796. C       Find out name, and display it
  2797.           jg = img - 1
  2798. C       x coord of cursor for month
  2799.           if (jg .gt. 5) jg = jg - 6
  2800. C       name in outstring
  2801.           ix = ( jg * 22 ) + 1
  2802. C
  2803.           if (img .gt. 6) then
  2804. C       First six months on top
  2805.         iy = 14
  2806. C       last six months on bottom
  2807.           else
  2808. C       half of screen
  2809.         iy = 2
  2810.           end if
  2811. c          ixx = (ix/2) + 2
  2812. c ***       if (lmneven(img)) ixx = ixx + 1
  2813.     call dtcat(ix,iy)
  2814. c          call dtcat(ixx,iy)
  2815. C       Position cursor and:
  2816.           write(*,3) monthn
  2817.  3          format($,21a1)
  2818. C       Write out the name.
  2819.  300        format($,40a)
  2820.  305        format($, 2a, 4(x, a))
  2821.  399        format($,a21)
  2822. C       Write out the name.
  2823.           If (img .gt. 6) then
  2824. C       Write out day of week
  2825.         iy = 15
  2826. C       Header names also, one
  2827.           else
  2828. C       line below month names
  2829.         iy = 3
  2830.           end if
  2831.           call dtcat(ix,iy)
  2832.           write(*,399) wknam
  2833.  
  2834.           If (img .gt. 6) then
  2835. C       Write out numbers for
  2836.         iy = 15
  2837. C       Days in each month:
  2838.         iyo = 12
  2839.           else
  2840.         iy = 4
  2841.         iyo = 0
  2842.           end if
  2843.           call dtcalcdow(ib,il,img,iye)
  2844. C       Now position the month
  2845.           ix = ix - 1
  2846. C       Off by 1.  CORRECT IT
  2847.           ixspa = 0
  2848.           ixo   = 0
  2849.           iyspa = 0
  2850.           call dtcdspmth(ib,il,ix,ixspa,iyo,iyspa)
  2851.  
  2852. c If displaying current year, mark today's date in reverse video
  2853.  
  2854.           if ((iye .eq. iyr) .and. (img .eq. imr)) then
  2855.         idw = mod(ib + idr -2, 7)
  2856. C Day of week and
  2857.         iwm = (idr + ib - 2)/7
  2858. C week of month (orig 0)
  2859.         if (img .gt. 6) iwm = iwm + 1
  2860. C Down one more line for Jul-Dec
  2861.         call dtcat((idw * 3) + ix + 1, iy + iwm)
  2862.         write (*, 301) esc,'[5;7m', idr, esc,resetvattr
  2863.  301            format ($, 2a, i2, 2a, $)
  2864.           end  if
  2865.  4      Continue
  2866.  
  2867.       call dtcat (1,23)
  2868. C Reposition cursor
  2869.  
  2870. c return next line read in and allow main pgm to decode...
  2871.       read(*,80,END=914)line
  2872.  80     format(84a1)
  2873.  914    Continue
  2874.     write(*,300) esc,'[?3l'
  2875.     Return
  2876.       end
  2877. C -h- strip.for   Tue Jul  8 16:06:45 1986
  2878. c-----------------------------------------------------------------------
  2879. C       Strip Daily Appointment subroutine (DTC Purge command)
  2880. C       part of GLENN EVERHART'S MODS TO DTC program
  2881. C       Input: command line - 72 INTEGER*1s, format:
  2882. C               P [mmddyy]
  2883. c                    or
  2884. c               U [mmddyy] [hh:mm[>hh:mm]]
  2885. c                    or
  2886. c               X [mmddyy] [hh:mm[>hh:mm]] [mmddyy] [hh:mm[>hh:mm]]
  2887. C       Output:
  2888. c               Reads dtc.dat, and builds new dtc.dat, in the process
  2889. c       strips old appointments (before date) from file (P),
  2890. c       deletes appointments at specified time and date (U),
  2891. c       or re-schedules (eXchanges) appointments from d1*t1 to d2*t2
  2892. c for Amiga, since we don't have version numbers, build DTC.TMP and
  2893. c copy onto DTC.DAT (or whatever) later...
  2894. C-----------------------------------------------------------------------
  2895. c
  2896.  
  2897.       SUBROUTINE strip
  2898. C (line)
  2899.  
  2900. C       Declarations:
  2901. c
  2902.       include comdtc.INC
  2903.       include apptdtc.INC
  2904. c
  2905. C       Function constants: Purge
  2906. C       .. Unschedule
  2907.       parameter (idspp = 1)
  2908.       Parameter (idspu = 2)
  2909.       Parameter (idspx = 3)
  2910. C       .. eXchange
  2911. C       INTEGER*1 line(1)
  2912. C       input line
  2913. C       temporary string converting array
  2914.       INTEGER*1 temp(2), ll,
  2915.      1 ln1, ap1
  2916. C       For RDAPPT 'do while' loop
  2917.       Integer*4 eofflg, prveof,
  2918.      1  firstflg
  2919.       Integer*4   id, idx
  2920. C       Julian Day
  2921.       Integer*4 im, imx
  2922. C       Julian Month
  2923.       Integer*4 iye, iyx
  2924. C       Julian Year
  2925.       Integer*4 it1, it2, itx1, itx2
  2926. C time values 80 (8 AM) => 173 (5:30 PM)
  2927. c
  2928.       logical first
  2929. C       For X decode
  2930.        Character*1 ln1c
  2931.        equivalence (line, ln1)
  2932. c      equivalence (appoin, ap1)
  2933.        Equivalence (ln1,ln1c)
  2934.        include stmtfuncsp.for
  2935.        include comdtcd.inc
  2936. c
  2937.       include stmtfunc.for
  2938. C Get standard statement functions
  2939.  
  2940. c Parse input line:
  2941. c       Was there a P on the front?  If so, trim it off:
  2942. c
  2943.  
  2944.     iopn2=0
  2945. c flag we opened DTC.TMP, 1 if true...
  2946.       isavinc = incmod
  2947. C Save for increment in DATCVT
  2948.  
  2949.       first = .true.
  2950. C Set it regardless of path
  2951.  
  2952.       If ( ln1c .eq. 'P' ) then
  2953.  
  2954.           idisp = idspp
  2955. C Function to perform
  2956.  
  2957.       else
  2958.  
  2959.           if (ln1c .eq. 'U') then
  2960.         idisp = idspu
  2961.           else if (ln1c .eq. 'X') then
  2962.         idisp = idspx
  2963.           else
  2964.         go to 999
  2965. C Error, can't decode it
  2966.           end if
  2967.  
  2968.           it1 = 80
  2969. C Set comparison values
  2970.           it2 = 180
  2971.           itx1 = it1
  2972.           itx2 = it2
  2973.  
  2974.       End If
  2975.  
  2976.       call shrink (1, ifnb, lnb)
  2977.  
  2978.       if (ifnb .eq. 0) then
  2979.           if (idisp .eq. idspp) then
  2980.         call dtcidate(im,id,iye)
  2981. C set to today's date
  2982.           else
  2983.         go to 999
  2984. C Not enough info for U or X
  2985.           end if
  2986.       else
  2987. C               If the date was specified in command line then
  2988. c               set id, im and iye to the right values:
  2989. c
  2990.  10         call dtcdatcvt(3)
  2991. C (line)
  2992.  
  2993.           if (first) then
  2994. C Note we decode into
  2995.         im = idmo
  2996. C second set of values,
  2997.         id = iddy
  2998. C then copy into first set
  2999.         iye = ibigyr
  3000. C first (or only) time around
  3001.           end if
  3002. C (unlike Schlitz, we can go around twice)
  3003.  
  3004.           if (idisp .ne. idspp) then
  3005. C other than purge
  3006. c ***           itx2 = 175
  3007. C Set default for '*' or <null>
  3008.         call dtctimcvt(itx1, itx2)
  3009.         if (itx1 .eq. itx2)
  3010.      1      itx2 = itx2 + 1
  3011. C Add (10 mins) to allow semi-open interval
  3012.         if (first) then
  3013.             it1 = itx1
  3014.             it2 = itx2
  3015.             if (idisp .eq. idspx) then
  3016.                 if (ln1 .eq. 0) go to 999
  3017. C Error if nothing left
  3018.                 first = .false.
  3019.                 go to 10
  3020. C Re-cycle code
  3021.             end if
  3022. C Done unless X
  3023.         end if
  3024.           else
  3025. C P, guarantee no redisplay
  3026.         ln1 = 0
  3027. C Zap the line
  3028.           end if
  3029. C Done parse for U, X
  3030.       end if
  3031. C Done date/time parse
  3032.  
  3033.       ixhash = ihymd(iye, im, id)
  3034. C Calc hash for day of interest
  3035.  
  3036. c ***   type 950, ixhash
  3037. c *** 950       format(2z9.8)
  3038.  
  3039.       if (idisp .eq. idspp)
  3040.      1 then
  3041. C Set request date for RDAPPT
  3042.           irqhash(1) = ixhash
  3043. C Delete before
  3044.         else
  3045.           irqhash(1) = 0
  3046. C Look at everybody
  3047.       end if
  3048.  
  3049.       irqhash(2) = Z'7FFFFFFF'
  3050. C 'Til the end of time
  3051.  
  3052.       firstflg = 0
  3053. C Zero until file opened for write
  3054.  
  3055.       prveof = 0
  3056.       eofflg = -1
  3057.  
  3058.       do while (prveof .ge. 0)
  3059.  
  3060.           call dtcrdappt(eofflg, 1)
  3061. C Look at control entries
  3062.  
  3063.           if (eofflg .gt. 0)
  3064.      1     then
  3065.         eofflg = 0
  3066. C Don't open it on return
  3067.         go to 190
  3068. C but re-write it as is
  3069.  
  3070. C Test it now
  3071.           else if (eofflg .eq. 0)
  3072.      1     then
  3073.  
  3074. c ***   type 950, irchash
  3075.  
  3076.         iht = min0(max0(iht, 80), 173)
  3077. C Insure a kosher time value
  3078.  
  3079.         go to (110, 120, 130) idisp
  3080. C Dispatch on numeric value
  3081.         go to 190
  3082. C Bad call, re-write anyway?
  3083.  
  3084.  120            if ((irchash .eq. ixhash) .and.
  3085.      1      ((iht .ge. it1) .and. (iht .lt. it2)))
  3086.      2      go to 100
  3087. C Criteria for Unscheduling (deleting)
  3088.         go to 190
  3089. C Do re-write
  3090.  
  3091.  130            if ((irchash .eq. ixhash) .and.
  3092.      1      ((iht .ge. it1) .and. (iht .lt. it2)))
  3093.      2    then
  3094.  
  3095.             iht = itx1 + (iht - it1)
  3096. C Get updated time
  3097.             if (mod(iht, 10) .eq. 6) iht = iht + 4
  3098. C go to next hour
  3099.  
  3100.             if (iht .gt. itx2) go to 100
  3101. C Duration was shortened
  3102.  
  3103.             ihy = ibigyr
  3104. C Change dates
  3105.             ihm = idmo
  3106.             ihd = iddy
  3107.  
  3108.         end if
  3109. C Usually re-write
  3110. c
  3111.  110            continue
  3112. C Purge, re-write
  3113.  
  3114. C Can't open output till
  3115.  190            if (firstflg .eq. 0)
  3116.      1    then
  3117. C we have input
  3118. C
  3119.  
  3120.             close(3)
  3121. c            open(unit=3, file=FNc(1:fnsz), status='NEW',
  3122. c     1          form='FORMATTED',
  3123. c     1          err=999)
  3124. 9991    continue
  3125.             open(unit=3, file='DTC.TMP', status='NEW',
  3126.      1          form='FORMATTED',
  3127.      1          err=999)
  3128.       iopn2=1
  3129. c flag we got DTC.TMP open...
  3130.             firstflg = 1
  3131. C Output now open
  3132.  
  3133.         end if
  3134.  
  3135.         write (3, 201,err=9991) ihy, ihm, ihd, iht,
  3136.      1          apptstr(1:min0(max0(iaptln, 1), iaptlim))
  3137. c ***   1         (appoin(k), k=1, min0(max0(iaptln, 1), iaptlim))
  3138.  201            format(i4.4, 2i2.2, i3.3, x, a)
  3139. C New format, 19850806113
  3140.  
  3141.           end if
  3142. C eofflg
  3143.  
  3144.  100        prveof = eofflg
  3145. C Set loop condition
  3146.  
  3147.       end do
  3148. C while
  3149.  
  3150. C Purged everything?
  3151.       if (firstflg .eq. 0)
  3152.      1 then
  3153. C create empty file
  3154.  
  3155.           close(3)
  3156. c          open(unit=3, file=FNc(1:fnsz), status='NEW',
  3157. c     1  form='FORMATTED',
  3158. c     1  err=999)
  3159.           open(unit=3, file='DTC.TMP', status='NEW',
  3160.      1  form='FORMATTED',
  3161.      1  err=999)
  3162.           iopn2=1
  3163.           firstflg = 1
  3164. C Output now open
  3165.  
  3166.        end if
  3167.  
  3168.     if(iopn2.le.0)goto 9403
  3169. c Amiga ...
  3170. c rewind 1 and 2, then copy DTC.TMP into DTC.DAT (or wherever)
  3171. c    Rewind 1
  3172.         close(1)
  3173.         close(4)
  3174.         open(unit=4, file=FNc(1:fnsz), status='NEW',
  3175.      1  form='FORMATTED',err=999)
  3176. c re-open unit 4 if we can, for write...
  3177. c    Rewind 3
  3178.           close(3)
  3179.           open(unit=3, file='DTC.TMP', status='old',
  3180.      1  form='FORMATTED',
  3181.      1  err=999)
  3182.  
  3183. 9402    continue
  3184.     Read (3,201,end=9401,err=9401) ihy,ihm,ihd,iht,apptstr
  3185. c read temp file, write back new appt file
  3186.         write (4, 201,err=9401) ihy, ihm, ihd, iht, apptstr
  3187. c 201            format(i4.4, 2i2.2, i3.3, x, a)
  3188.     goto 9402
  3189. 9401    continue
  3190.     close(3,Status='delete')
  3191.         close(4)
  3192.         firstflg=0
  3193.         iopn2=0
  3194. 9403    continue
  3195.         close(3)
  3196.         close(2)
  3197.         close(4)
  3198.         close(1)
  3199. C Done with new files
  3200.  
  3201.         return
  3202.  
  3203.  999    write (*, 990)
  3204. C Error on decode, write nastygram
  3205.  990    format($,'Syntax or file-open (write) error.', $)
  3206.        ln1 = 0
  3207. C Inhibit rescan
  3208. c
  3209.       end
  3210. C -h- dtcdatcvt.for       Tue Jul  8 16:07:21 1986
  3211. c Date conversion function (part of DTC), derived from DATMUN,
  3212. c except decodes the values directly into DEFDAT and shrinks LINE,
  3213. c rather than schlep LINE back and forth to kingdom come.
  3214. C Modified 850422, CG, to restrict values of month/day/year
  3215. C modified 850325, 850726 & 850731, CG, to allow any of the following:
  3216. c       d{d}/m{m}/{y}y, d, dd, dmm, ddmm, dmmyy, ddmmyy, dmmyyyy, ddmmyyyy
  3217. c                                                       for D or W functions
  3218. c       m{m}/{y}y, m, mm, myy, mmyy, mmyyyy, myyyy      for M
  3219. c       y, yy, yyy, yyyy                                for Y
  3220. C plus dd-mon-yy, dd-mm-yy, dd-xii-yy formats
  3221. C function:
  3222. c  Convert a line starting with a date of form
  3223. c       mmddyy OR mm/dd/yy OR dd-mon-yy OR dd-romn-yy
  3224. c  to binary equivalents, and remove from line, copying binary values
  3225. c  to DEFDAT in common.
  3226. C  Leaves whatever follows the date alone.
  3227. c  Added for DTC to not have to use such a crock date
  3228. c  format as the original; too hard to use otherwise.
  3229.  
  3230.       Subroutine dtcdatcvt (nf)
  3231. C (line,nf)
  3232. c
  3233. c      implicit none
  3234. c
  3235.       Integer*4  nf
  3236. C Number of fields expected
  3237. c
  3238.       include comdtc.INC
  3239. c
  3240.       INTEGER*1 nb, l1, l2, l3, l4, lxx(4), work(icmln), tb6(6)
  3241. C,
  3242. c
  3243. C lengths of months (30 days hath Sept ...)
  3244.       Integer*4 lm(12)
  3245. c
  3246. C Min chars to recognize month names
  3247.       Integer*4 minln(12)
  3248.  
  3249. C Decode month names, or European style w/ Roman months
  3250.       character*4 rch,mab(12),rom(12)
  3251.  
  3252.       Integer*4 i, k, kkk, n, nn, ix, ixyr, ixmo, ixdy, nfd,
  3253.      1  ifnb, lnb, lcount
  3254.  
  3255.       logical longyr
  3256. C If year entered as 3 chars or more
  3257.  
  3258.       integer*2 iwk(42), lw1
  3259.       integer*1 iwkk(84),ln1
  3260.       Character*1 ln1c
  3261.       Equivalence (work,iwkk)
  3262. C 2 chars at a time
  3263. c
  3264.       Integer*4  ll1
  3265.  
  3266.       equivalence(line(1),ln1)
  3267.       equivalence (ln1,lw1),(ll1,rch)
  3268.       equivalence (rch, lxx), (work, iwk)
  3269.       equivalence(line(1),ln1c)
  3270. c
  3271.       Integer*4 icvt10, icur
  3272.       INTEGER*1 ich
  3273.       include stmtfuncsp.for
  3274.       include comdtcd.inc
  3275.  
  3276.       Data lm
  3277.      1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
  3278. c
  3279. C Min chars to recognize month names
  3280.        Data minln
  3281.      1 /2, 1, 3, 2, 3, 3, 3, 2, 1, 1, 1, 1/
  3282.  
  3283. C Decode month names, or European style w/ Roman months
  3284.       Data
  3285.      1 mab / 'JANU', 'FEBR', 'MARC', 'APRI', 'MAY ', 'JUNE',
  3286.      2      'JULY', 'AUGU', 'SEPT', 'OCTO', 'NOVE', 'DECE'/,
  3287.      3 rom / 'I   ', 'II  ', 'III ', 'IV  ', 'V   ', 'VI  ',
  3288.      4      'VII ', 'VIII', 'IX  ', 'X   ', 'XI  ', 'XII '/
  3289.  
  3290.        include stmtfunc.for
  3291.       icvt10(icur, ich) = (icur * 10) + icvtbn1(ich)
  3292. C conversion function stage
  3293.  
  3294. c Begin code
  3295.  
  3296.       longyr = .false.
  3297. C set default of century calculation
  3298.  
  3299. c Initialize default values for omitted fields
  3300.  
  3301.       ixyr = ibigyr
  3302. C Copy current values
  3303.       ixmo = idmo
  3304. C from common
  3305.       ixdy = iddy
  3306.       if (numeric(ln1)) then
  3307. C Dates must start with number
  3308.  
  3309.           work(1) = ln1
  3310. C Copy first character
  3311.           ix = icvtbn1(ln1)
  3312. C Compute value on the fly
  3313. c
  3314.           do (n = 2, (nf * 2) + 2)
  3315. C Allow [mm][dd][yyyy]
  3316. c
  3317.         l1 = line(n)
  3318. C Copy current character
  3319.  
  3320. C Field separators: slash
  3321.         if (l1 .eq. ichar('/'))
  3322.      1      go to 100
  3323. C for mm/dd/yy form
  3324.  
  3325. C .. dash
  3326.         if (l1 .eq. ichar('-'))
  3327.      1      go to 200
  3328. C for dd-mmm-yy form
  3329.  
  3330.         if ((l1 .eq. ichar(':')) .or. (l1 .eq.ichar('>')))
  3331.      1      go to 999
  3332. C hour-string first, return default values
  3333. C anything else:
  3334.         if (.not. numeric(l1))
  3335.      1      go to 300    
  3336. C mmddyy, minus some characters, fake whatever is required
  3337.  
  3338.         work(n) = l1
  3339. C Don't recopy
  3340.         ix = icvt10(ix, l1)
  3341. C continue conversion
  3342.  
  3343.           end do
  3344.  
  3345.           n = (nf * 2) + 3
  3346. C Set shrink value if no delimiter
  3347.  
  3348.           go to 300
  3349. C Go convert it
  3350.  
  3351.       else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) then
  3352.           k = incmod
  3353. C Save current value
  3354.           call dtcdatinc
  3355. C Convert incremental date
  3356.           incmod = k
  3357. C Restore
  3358.       else if (ln1c .eq. '=') then
  3359.           kkk = 1
  3360. C Place holder, strip only, date n/c
  3361.           go to 950
  3362.       end if
  3363. C (don't want to reformat whole file)
  3364.  
  3365.       go to 999
  3366. C All done here
  3367.  
  3368. c handle mm/dd or mm/dd/yy{yy} (for D, W, M or Y)
  3369. c or mm/yy{yy} (for M or Y)
  3370.  
  3371.  100    continue
  3372. C Here for '/' encountered in first scan loop
  3373.  
  3374.       k = n + 1
  3375. C next character to look at
  3376.       l1 = line(k)
  3377.       if (.not. numeric(l1)) go to 300
  3378. C nnnn/x ???
  3379.  
  3380.       ixmo = ix
  3381. C First field is always month in "/" notation
  3382.  
  3383.       ix = icvtbn1(l1)
  3384. C Start 2nd conversion
  3385.  
  3386.       do (n = k + 1, 20)
  3387. C should be plenty
  3388.  
  3389.           l1 = line(n)
  3390. C get character
  3391.           if (l1 .eq. ichar('/')) go to 110
  3392. C Found second /
  3393.           if (.not. numeric(l1)) go to 120
  3394. C End of scan
  3395.           ix = icvt10(ix, l1)
  3396. C convert
  3397.  
  3398.       end do
  3399.  
  3400.       n = 21
  3401. C Set it
  3402.  
  3403.  120    if (nf .eq. 3) then
  3404.           ixdy = ix
  3405. C 2nd field is day
  3406.       else
  3407.           ixyr = ix
  3408. C .. year
  3409.           longyr = ((n - k) .gt. 2)
  3410.       end if
  3411.  
  3412.       go to 900
  3413.  
  3414.  110    l1 = line(n+1)
  3415. C Found 2nd slash, check for third field
  3416.       if (.not. numeric(l1)) go to 120
  3417. C left field
  3418. C
  3419.  
  3420.       k = n + 1
  3421.  
  3422.       ixdy = ix
  3423. C 2nd has to be day
  3424.  
  3425.       ixyr = icvtbn1(l1)
  3426. C Start 3rd conversion (year)
  3427.  
  3428.       do (n = k + 1, 20)
  3429. C get more numerics
  3430.  
  3431.           l1 = line(n)
  3432.           if (.not. numeric(l1)) go to 910
  3433.           ixyr = icvt10(ixyr, l1)
  3434.  
  3435.       end do
  3436.  
  3437.       n = 21
  3438. C mark next character
  3439.  
  3440.       go to 910
  3441. C set for SHRINK
  3442.  
  3443. c handle dd-mon-yy, dd-mm-yy, or dd-roman-yy
  3444.  
  3445.  200    continue
  3446. C Here for '-' in first scan loop
  3447.  
  3448.       ixdy = ix
  3449. C Copy converted day field
  3450.  
  3451.       rch = '    '
  3452. C initialize for alpha month name, or Roman numerals
  3453.  
  3454.       k = n + 1
  3455. C next char after "-"
  3456.  
  3457.       l1 = line(k)
  3458.  
  3459.       if (numeric(l1)) then
  3460. C European format dd-mm-yy
  3461.  
  3462.           ixmo = icvtbn1(l1)
  3463. C go for it directly
  3464.  
  3465.           do (n = k + 1, 20)
  3466.  
  3467.         l1 = line(n)
  3468.  
  3469.         if (.not. numeric(l1)) go to 210
  3470.  
  3471.         ixmo = icvt10(ixmo, l1)
  3472.  
  3473.           end do
  3474.  
  3475.           n = 21
  3476.  
  3477.       else if (alpha(l1)) then
  3478.  
  3479.           lxx(1) = l1 .and. z'5F5f5f5f'
  3480. C Set first char for name or roman
  3481.  
  3482.           lcount = 1
  3483.  
  3484.           do (nn = k + 1, k + 6)
  3485. C should find "-" by then
  3486.  
  3487.         l1 = line(nn)
  3488.         if (l1 .eq. ichar('-')) go to 230
  3489. C Start search
  3490.         if (.not. alpha(l1)) go to 230
  3491. C also terminate
  3492.         if (lcount .lt. 4) then
  3493. C room for at least one more
  3494.             lcount = lcount + 1
  3495.             lxx(lcount) = l1 .and. z'5F5f5f5f'
  3496. C Copy character
  3497.         end if
  3498.           end do
  3499.  
  3500.           nn = k + 6
  3501.  
  3502.  230        continue
  3503.  
  3504.           do (i = 1, 12)
  3505. C Loop over months
  3506.         if (rch .eq. rom(i)) go to 250
  3507. C Found match in roman set
  3508.         if (lcount .ge. minln(i)) then
  3509.             if (rch(1:lcount) .eq. mab(i)(1:lcount))
  3510.      1          go to 250
  3511. C Found match in alpha names
  3512.         end if
  3513.  
  3514. C Note: last two IF statements above replace original horrendous sequence of
  3515. c IF-THEN-ELSEs to see if month was J then A, or F, or M then A then R, etc
  3516. C
  3517.          end do
  3518.  
  3519. c Fell out of loop, leave current month
  3520.  
  3521.           go to 300
  3522. C Unknown month or roman seq, back up before "-"
  3523.  
  3524.  250        ixmo = i
  3525. C iwk(1) = icvtbcd(i)
  3526.           n = nn
  3527. C Accept characters
  3528.  
  3529.       else
  3530. C "-" followed by non alphanumeric
  3531.           go to 300
  3532.       end if
  3533.  
  3534.  210    if (l1 .ne. ichar('-')) go to 900
  3535. C See if year follows
  3536.  
  3537.       k = n + 1
  3538.       l1 = line (k)
  3539.  
  3540.       if (.not. numeric(l1)) go to 910
  3541. C First dash is left
  3542.       ixyr = icvtbn1(l1)
  3543.  
  3544.       do (n = k + 1, 30)
  3545.  
  3546.           l1 = line (n)
  3547.  
  3548.           if (.not. numeric(l1)) go to 910
  3549.  
  3550.           ixyr = icvt10(ixyr, l1)
  3551.  
  3552.       end do
  3553.  
  3554.       n = 31
  3555.  
  3556.  910    longyr = ((n - k) .gt. 2)
  3557. C Set logic value
  3558.  
  3559.       go to 900
  3560.  
  3561. 300      continue
  3562. C Short string found, fix it up
  3563.  
  3564.       nfd = n/2
  3565. C Number of 2-char groups found
  3566.  
  3567.       longyr = (nfd .gt. nf)
  3568. C check for default or forced century
  3569.  
  3570.       if ((n .and. 1) .eq. 0) then
  3571. C Example: n = 5 for 4 chars found (0 mod 2)
  3572.           work(1) = '0'
  3573. C Force even number of characters
  3574.           do (i = 2, n)
  3575.         work(i) = line(i - 1)
  3576. C Shift line over by 1
  3577.           end do
  3578.       end if
  3579.  
  3580.       go to (310, 320, 330) nf
  3581. C Dispatch on # expected fields
  3582.       go to 900
  3583. C Bad value ???
  3584.  
  3585.  310    ixyr = ix
  3586. C take year: Y [yy]
  3587.       go to 900
  3588. C End case
  3589.  
  3590.  320    ixmo = icvtbin(iwkk(1))
  3591. C M mm
  3592.       if (nfd .eq. 2) ixyr = icvtbin(iwkk(3))
  3593. C M {m}myy
  3594.       if (nfd .eq. 3) ixyr = mod(ix, 10000)
  3595. C M {m}myyyy
  3596.       go to 900
  3597. C End case
  3598.  
  3599.  330    if (nfd .eq. 1) ixdy = icvtbin(iwkk(1))
  3600. C D {d}d {only}
  3601.  
  3602.       if (nfd .ge. 2) then
  3603. C D [mm]dd[yy]
  3604.           ixmo = icvtbin(iwkk(1))
  3605. C D {m}mdd
  3606.           ixdy = icvtbin(iwkk(3))
  3607. C D {m}mdd
  3608.       end if
  3609.  
  3610.       if (nfd .eq. 3) ixyr = icvtbin(iwkk(5))
  3611. C D {m}mddyy
  3612.       if (nfd .eq. 4) ixyr = mod(ix, 10000)
  3613. C D {m}mddyyyy
  3614.  
  3615.  900    continue
  3616. C common clean-up & return
  3617.  
  3618. C Check for 1-99 AD
  3619.       if ((ixyr .lt. 100) .and. (.not. longyr))
  3620.      1   ixyr = ixyr + ((ibigyr/100)*100)
  3621. C add "current" century
  3622.  
  3623.       if (islpyr(ixyr))
  3624.      1 then
  3625.           lm(2) = 29
  3626. C Set for Leap Years
  3627.         else
  3628.           lm(2) = 28
  3629. C reset for "common" years
  3630.       end if
  3631.  
  3632.       ibigyr = ixyr
  3633. C Explicit year
  3634.       idmo = min0(max0(ixmo, 1), 12)
  3635. C Limit values
  3636.       iddy = min0(max0(ixdy, 1), lm(idmo))
  3637. C ..
  3638.  
  3639.       kkk = n - 1
  3640. C Change index of next char to count
  3641.  
  3642.  950    idyr = mod(ibigyr, 100)
  3643. C Set value
  3644.  
  3645.       if (kkk .gt. 0)
  3646.      1 call shrink (kkk, ifnb, lnb)
  3647. C Unload the stuff we used
  3648.  
  3649.  999    return
  3650. C Miscellaneous exits
  3651.        end
  3652. c -h- dtctimcvt.for       Tue Jul  8 16:08:13 1986
  3653. c Subroutine to extract and convert time-of-day string for DTC package
  3654. c Converts string of form hh:mm to Integer*4 between 80 and 173
  3655. c (half-hour intervals).  If range h1:m1>h2:m2 is present, second
  3656. c value is returned, else same as t1>t1.
  3657.  
  3658. c Special cases
  3659. c       *       =>      {itr1}>{itr2}
  3660. c       E or EV =>      17:00
  3661. c       h:      =>      0h:00
  3662. c       h:n     =>      0h:n0   (if n .ge. 3, then 3, else 0)
  3663. c       h1>h2   =>      h1:00>h2:00
  3664.  
  3665. c If ':' or '>' is not 2nd or 3rd character, or not '*', 'E' or 'EV',
  3666. c entire string is left untouched, and default values are returned
  3667. c (parameters unchanged)
  3668.  
  3669.       subroutine dtctimcvt (itr1, itr2)
  3670.  
  3671.       include comdtc.INC
  3672.  
  3673.       INTEGER*1 ll, ln1, wk(2)
  3674.       integer*2 iwk
  3675.       character*2 icwk
  3676.       equivalence(icwk,iwk)
  3677.       integer*1 iwkk
  3678.       logical first, expectmin
  3679.  
  3680.       equivalence (line(1), ln1), (iwk, wk)
  3681.       equivalence(iwkk,wk(1))
  3682.       include stmtfuncsp.for
  3683.       include comdtcd.inc
  3684.       include stmtfunc.for
  3685.  
  3686.       it1 = itr1
  3687. C Caller's limits
  3688.       it2 = itr2
  3689. C (formerly 8:00 AM > 5:30 PM)
  3690.  
  3691.       ix = 0
  3692. C Amount to strip
  3693.       if(ln1.gt.96)ln1=ln1-32
  3694.       if (ln1 .eq. ichar('*')) then
  3695. C Check special cases first
  3696.  
  3697.           ix = 1
  3698. C Defaults, dump 1 char
  3699.  
  3700.       else if ((ln1 ) .eq. ichar('E')) then
  3701.  
  3702.           it1 = 170
  3703. C Set eventide
  3704.           it2 = it1
  3705.  
  3706.           ix = 1
  3707.           if(line(2).gt.96)line(2)=line(2)-32
  3708.           if ((line(2)) .eq. ichar('V')) ix = 2
  3709.  
  3710.       else
  3711.  
  3712.           i = 0
  3713. C Temp index
  3714.           first = .true.
  3715. C Helpful
  3716.  
  3717.  10         if (numeric(line(i+1))) then
  3718.  
  3719.         if (numeric(line(i+2))) then
  3720.             wk(1) = line(i+1)
  3721.             wk(2) = line(i+2)
  3722.             read(icwk,850)ih
  3723. 850     format(BZ ,I2)
  3724.             ih=ih*10
  3725. c            ih = icvtbin(iwkk) * 10
  3726.             i = i + 2
  3727.         else
  3728.             ih = icvtbn1(line(i+1)) * 10
  3729.             i = i + 1
  3730.         end if
  3731.  
  3732.         if (line(i+1) .eq. ichar(':')) then
  3733.             i = i + 1
  3734.             if (numeric(line(i+1))) then
  3735.                 im = icvtbn1(line(i+1))
  3736.                 if (im .ge. 3) then
  3737.                     im = 3
  3738.                 else
  3739.                     im = 0
  3740.                 end if
  3741.                 ih = ih + im
  3742.                 i = i + 1
  3743.                 if (numeric(line(i+1))) i = i + 1
  3744. C Just ignore it
  3745.             end if
  3746.             ix = i
  3747. C Accept all processed chars
  3748.         end if
  3749.  
  3750.         if ((ih .ge. 10) .and. (ih .lt. 70))
  3751.      1     ih = ih + 120
  3752. C Force early AM to PM
  3753.         ih = min0(max0(ih, 80), 180)
  3754. C Normalize within limits
  3755.  
  3756.         if (line(i+1) .eq. ichar('>')) then
  3757.             i = i + 1
  3758.             ix = i
  3759. C Insure it gets copied
  3760.             it2 = ih
  3761.             if (first) then
  3762.                 it1 = it2
  3763.                 first = .false.
  3764.                 go to 10
  3765.             end if
  3766.         else if (ix .ne. 0)     then
  3767. C Got some numeric
  3768.             if (first) then
  3769.                 it1 = ih
  3770. C terminated by ':'
  3771.                 it2 = ih
  3772. C first time t1>t1
  3773.             else
  3774.                 it2 = ih
  3775. C 2nd numeric
  3776.                 ix = i
  3777. C Claim everything looked at
  3778.             end if
  3779. C Which time
  3780.         end if
  3781. C Range delimiter ('>')
  3782.           end if
  3783. C First numeric
  3784.       end if
  3785. C All others unrecognized (includes EOL)
  3786.  
  3787.       itr1 = it1
  3788. C All exit here
  3789.       itr2 = max0(it2, it1)
  3790. C Make sure range OK
  3791.  
  3792.       if (ix .ne. 0) call shrink (ix, ifnb, lnb)
  3793. C Unload what we've used
  3794.  
  3795.       end
  3796. C -h- shrink.for  Tue Jul  8 16:08:41 1986
  3797. c Subroutine to shift LINE to left after current item has been scanned
  3798. c deletes blanks between that point and first non-blank character
  3799. c Performs no operation if current item is EOL (binary 0)
  3800.  
  3801. c Sets return arguments pointing to first and last non-blank characters
  3802.  
  3803.       subroutine shrink (iskip, ifnbr, lnbr)
  3804. c
  3805.       include comdtc.INC
  3806.  
  3807.       INTEGER*1 ll
  3808.       include comdtcd.inc
  3809.  
  3810.       ifnb = 0
  3811.       lnb = 0
  3812.  
  3813.       if (line(1) .eq. 0) go to 999
  3814. C Exit immediately
  3815.  
  3816.       ix = iskip + 1
  3817. C start looking
  3818.       do while ((ix .le. icmln) .and. (line(ix) .ne. 0))
  3819.       if (line(ix) .gt. 32) go to 10
  3820. C Found something
  3821.       ix = ix + 1
  3822.       end do
  3823.       line(1) = 0
  3824. C Flag end, no copy
  3825.       go to 999
  3826.  
  3827.  10     ifnb = 1
  3828.       lnb = 1
  3829.  
  3830.       Do (i = 1, icmln-ix)
  3831.  
  3832.           ll = line(ix)
  3833.           line(i) = ll
  3834.           if (ll .eq. 0) go to 999
  3835. C Stop at EOL
  3836.           if (ll .gt. 32) lnb = i
  3837.           ix = ix + 1
  3838.       end do
  3839.       line(min0(lnb+1, icmln)) = 0
  3840. C Flag EOL if not found
  3841.  
  3842.  999    ifnbr = ifnb
  3843. C Set return values
  3844.       lnbr = lnb
  3845.  
  3846.       end
  3847. C -h- dtcat.for   Tue Jul  8 16:09:05 1986
  3848.       subroutine dtcat(ic,ir)
  3849. C x, y
  3850. c
  3851.       include comdtc.INC
  3852. C Need ITERM
  3853.       include escdtc.INC
  3854. C
  3855.       include comdtcd.inc
  3856.       include escdtcd.inc
  3857.       write(*,773)
  3858. 773   format(' ')
  3859. c write once to flush extra junk out... then position.
  3860.       write(*, 2, err=3) esc,'[',ir,';',ic,'H'
  3861.  2      format($,2a1,i2.2,a1,i3.3,a1,$)
  3862. C Max rows is 2-digit number
  3863. c
  3864.       return
  3865. c
  3866.  3      write (*,10) esc,homescrn, ir, ic
  3867.  10     format($, 2a, 'Error in DTCAT, row/col =', 2z5.4, ' (hex).')
  3868.       end
  3869. C -h- gaby.for    Tue Jul  8 16:10:23 1986
  3870. c-----------------------------------------------------------------------
  3871. C       Subroutine Gaby
  3872. C       Part of Mitch Wyle's DTC program
  3873. C       return a string corresponding to the month number
  3874. c       Month number contained in im.  Send back string in monthn.
  3875. c       (JANUARY for 1, etc.)
  3876. C-----------------------------------------------------------------------
  3877. C       modified 850315 - Center month names in table, use mixed case - CG
  3878.  
  3879.       SUBROUTINE gaby(im,monthn)
  3880.  
  3881. C       Declarations:
  3882. c
  3883.       INTEGER*1 monthn(9)
  3884. C       Table of month names and numbers (centered, even lengths biased left):
  3885. c
  3886.  
  3887.       INTEGER*1 months(9,14)
  3888.       character*9 monthch(14)
  3889.  
  3890.       equivalence (months, monthch)
  3891. C       Select the right month and fill monthn with it:
  3892. c
  3893.       Data monthch/           'December ',
  3894.      1 ' January ', 'February ', '  March  ', '  April  ',
  3895.      2 '   May   ', '  June   ', '  July   ', ' August  ',
  3896.      3 'September', ' October ', 'November ', 'December ',
  3897.      4 ' January '/
  3898.  
  3899.  
  3900. C ALLOW FOR OVERFLOWS...
  3901.       IMM=IM+1
  3902. c ***   monthn = monthch(imm)
  3903. C String assignment
  3904. c
  3905.       Do 1 i=1,9
  3906. C INTEGER*1-at-a-time
  3907.           Monthn(i) = months(i,imm)
  3908.  1      Continue
  3909.  
  3910. c       All done.
  3911.  
  3912.       return
  3913.       end
  3914. c -h- ICVT routines
  3915.        Integer*2 function Icvtbin(ich2)
  3916.        Character*2 ich2
  3917.        Character*2 wrk
  3918.        integer*2 iwrk,ians
  3919.        Equivalence(wrk,iwrk)
  3920. c convert 2 digit Integer*4 to number
  3921. c avoid trick version from VAX that depends on byte
  3922. c ordering (which fails on MC68000).
  3923.        wrk=ich2
  3924.        Read(wrk,1,err=2)ians
  3925. 1      Format(BN,I2)
  3926. 2      Continue
  3927.        Icvtbin=ians
  3928.        Return
  3929.        End
  3930.        Function Icvtbn1(nnn)
  3931.        Integer*1 nnn
  3932.        Integer*4  kkk
  3933.        kkk=48
  3934.        if(nnn.ge.48.and.nnn.le.57)kkk=nnn
  3935.        kkk=kkk-48
  3936. c return 0 or digit value...
  3937.        Icvtbn1=kkk
  3938.        Return
  3939.        End
  3940. d       subroutine dely
  3941. d       Integer*4 idly,i1
  3942. d       common/xxxyyy/idly
  3943. d       idly=0
  3944. d       do 1 i1=1,15000
  3945. d       idly=idly+i1
  3946. d1      continue
  3947. d       idly=idly/100
  3948. d       return
  3949. d       end
  3950.  
  3951.  
  3952.