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