C -h- dtcvax.for  Tue Jul  8 16:01:48 1986
c------------------------------------------------------------------------
C               Desk Top Calender Program
C                                                     Mitch Wyle 17.11.82
C       This program provides an on-line appointment calender system
c       for daily appointments, week-at-a-glance schedule, and month-
c       at-a-glance schedule.  A facility is provided for a daily re-
c       minder.
C       The program has help and menu prompting facilities for the new
c       user and the ability to interpret an MCR line for the experienced
c       user.  The CRT screen functions are specific to the DEC VT-100
c       screen terminal, as is the FORTRAN code.
C------------------------------------------------------------------------
C       Compile:
C------------------------------------------------------------------------

c       Declarations:

      include comdtc.INC
C Get common file
      include escdtc.INC
C Frequently-used escape sequences
      include appdtc.Inc
c Initialize common declared above
      include dtcxidate.inc
      INTEGER*1 ln1
      Character*1 ln1c
c first character of line
      integer*2 ln2
      integer*1 incsel(4)
      logical exflag
C first two characters of line
      character*84 comlin
      character*9 fnamech
c      character*60 fnamchh
c      character*18 fname
C Make FORTRAN OPEN happy
      equivalence (comlin, line(1))
      equivalence (line(1),ln1)
      equivalence (ln1, ln2)
      Equivalence (ln1,ln1c)
c      equivalence (line(1),ln1)
      equivalence (fname,fnamech)
c      equivalence (fnamchh,fname)

      character*2 khomescrn,kclrscrn,kdhdw1,kdhdw2,
     1 kdwide,kresetvattr,krevattr
      Integer*4  kincmod
      include stmtfuncsp.for
      Data comlin /' '/
      Data fnamech /'DTC.DAT'/
C Make FORTRAN OPEN happy
C Length of default value
       include comdtcd.inc
       include escdtcd.inc
      data khomescrn /'[H'/, kclrscrn /'[J'/,
     1    kdhdw1 /'#3'/, kdhdw2 /'#4'/, kdwide /'#6'/,
     2    kresetvattr /'[m'/, krevattr /'[7m'/

      data kincmod /1/
C Default to day

c End common initialization

C INCMOD will flag day/week/month/year default increment...
c 1=day, 2=week, 3=month,4=year
      Data incsel /'D', 'W', 'M', 'Y'/
C Auto display after +/-

C       Integer*4  lib$get_foreign
C Get DCL command line, unparsed

      Data exflag/.false./
C True if data on DCL command line

      include stmtfunc.for
C Get useful statement functions

c Begin code:
       fname(18)=0
       fnsz=9
       comlen=0
       comidx=0
       homescrn=khomescrn
       clrscrn=kclrscrn
       dhdw1=kdhdw1
       dhdw2=kdhdw2
       dwide=kdwide
       resetvattr=kresetvattr
       revattr=krevattr
       incmod=kincmod
c       Iterm=9
c first set up default data filename
C >>> Assumes VT100, interactive <<<
980   continue
c Escape sequences used:
C       <ESC>7          Save cursor and video attributes
c       <ESC>8          Restore ...
c       <ESC><          Exit ATS mode
c       <ESC>>          Keypad numeric mode (Exit Alternate Keypad mode)
c       <ESC>[?4l       Reset scroll mode (jump)
c       <ESC>[?6l       Reset origin mode (absolute)
c       <ESC>[r         Set top/bottom margins (default - 1:24)
c       <ESC>[m         Graphic rendition = primary (default)
c       <ESC>[H         Set cursor at home position (upper left)
c       <ESC>(B         G0 (SI/^O) = US ASCII
c       <ESC>)0         G1 (SO/^N) = Special graphics
c       ^O              Shift In (Select G0 (US ASCII))

C Clean up terminal
C [m
      write (*,100)
     1 esc,'<', esc,'>',
     2 esc,'[?4l', esc,resetvattr,
     4 esc,'7', esc,'[?6l', esc,'[r', esc,'8'
c       write(*,100) esc,'[0;0H',esc,'[26t',esc,'[138u'
c set private Amiga modes to inhibit wrap...
c set so smallfont will (we hope) have all positions available.
 100    format ($, 21a, $)
C Escape sequences
      ibigyr=1987
      iddy=4
      idmo=7
      call dtcidate(idmo,iddy,ibigyr)
C Get current date
          call dtcicomd

c       First time, get the MCR line, then parse and process it:

c INIT  exflag=.false.
C Assume terminal input

C       istat=lib$get_foreign(comlin,,comlen)
C       if ((istat .ne. ss$_normal) .or. (comlen .eq. 0))
C       1   go to 77
      GOTO 77
c Allow for single operation to insert an appointment in upper & lower case

C       if (ln1 .eq. '"') then
C User quoted the line
C           do (i = 2, comlen)
C First of many re-copy opns
C               line(i-1) = line(i)
C copy it down
C           end do
C           comlen = comlen - 1
C       end if

C       line(min0(comlen+1, icmln)) = 0
C Set end of line character
C       exflag=.true.
C Flag for exit after one command

c Generalized parser and scanner routine for line:

 1      continue
C Loop up here on any input.

c initialize flags to normal search display sense (show occupied times)
c and no special meeting setups...

      rdspfg=0
      ctlfg=0

 1111   continue
C Re-enter here, after "+", etc

      comidx = 1
C Initialize for parsing

      if (lcalpha(ln1))
     1   ln1 = ln1 -32
C Change to upper case
c Find out what's seen in the line...
      If ((ln1c .eq. 'D')
     1   .or. (ln1c .eq. '=')
     2   .or. (ln1c .eq. '*'))
     3 then
          incmod=1
          call day
C (line)
C display daily,
          go to 6

      else if (ln1c .eq. 'W')
     1 then
          incmod=2
          call week
C (line)
C weekly,
          go to 6

      else if (ln1c .eq. 'M')
     1 then
          incmod=3
          call month
C (line)
C or monthly schedules,
          go to 6

      else if (ln1c .eq. 'Y')
     1 then
          incmod=4
          call year
C (line)
C or full-year calendar
          go to 6

c flag multiple schedule of meeting to enable multi entry
      else if (ln1c .eq. 'S')
     1 then
          ln1c='D'
          ctlfg=1
          incmod=1
          call day
C (line)
          go to 6

c use G as a schedule that will write appointments in current and
c all indirected files.
      else if (ln1c .eq. 'G')
     1 then
          ln1c='D'
          ctlfg=2
          incmod=1
          call day
C (line)
          go to 6

      else if ((ln1c .eq. '+') .or. (ln1c .eq. '-'))
     1 then
          Call dtcdtinc
C (line,Incmod)
          if (ln1 .ne. 0) go to 450
C something left, schedule it

          ln1c = incsel(incmod)
C Phony line
          line(2) = 0
C End-of-line ?
          comlen = 1
          go to 1111
C Display based on incr

c reverse display flag so we hunt up free slots... note week, month
c routines all get hacked on to do this...
c reparse line after copying it down 1 character to remove the 'N'
      else if (ln1c .eq. 'N')
     1 then
          rdspfg=1
          call shrink(1, ifnb, lnb)
          go to 1111

      else if (ln1c .eq. 'P')
     1 then
C Purge old appointments
          call strip
C (line)
          go to 6

      else if ((ln1c .eq. 'U') .or. (ln1c .eq. 'X'))
     1 then
          call strip
C (line)
C Cancel or reschedule
          if (ln1c .gt. ' ') go to 1
C Re-scan if leftover chars
          go to 6

      else if (ln1c .eq. 'L')
     1 then
c for locating free time, use week function and scan map
          ctlfg=1
          ln1c='W'
          incmod=2
          call week
C (line)
          go to 6

      else if (ln1c .eq. 'T')
     1 then
          ln1c='D'
          incmod=1
          call day
C (line)
C today's memos then exit
          go to 999

      else if (ln1c .eq. 'R')
     1 then
          ln1c='W'
          incmod=2
          call week
C (line)
C remind one of this week
          go to 999

      else if (ln1c .eq. 'C')
     1 then
C calendar print for month
          incmod=3
          call month
C (line)
          go to 999

      else if (ln1c .eq. 'I')
     1 then
C Reset default date
          call dtcicomd
C Process possible date string
          go to 6
C (for testing mods)

      else if ((ln1c .eq. 'H') .or. (ln1c .eq. '?'))
     1 then
          call dhelp
C HELP
C (instructions)
          go to 6

c f filename enters new default data file name to use...
      else if (ln1c .eq. 'F')
     1 then
          call shrink(1,ifnb, lnb)
          if (ifnb .eq. 0)
     1     then
        fnamech = 'DTC.DAT'
        fnsz = 7
C Length of default value
            else
        do (i=1,lnb)
            fname(i)=line(i)
        end do
        fnsz=lnb
          end if
          fname(fnsz+1)=0
C Make FORTRAN OPEN happy
          go to 6

      else if ((ln1c .eq. 'Q') .or.
     1 ((line(1).eq.ichar('E').or.line(1).eq.ichar('e')).and.
     2 (line(2).eq.ichar('X').or.line(2).eq.ichar('x')))) then
          go to 999
C Exeunt omnes

      else

C       Now get a bit fancy:  (play with the line string)
c
      if (ln1c .eq. 'E') go to 450
c
      If (.not. numeric(ln1)) go to 5
C unknown
c
 450    continue
C From E above, or leftovers for +/-
C The first character is a number or E,
c call the daily appointment subroutine:

      incmod=1
      line(icmln) = 0
C Tag e/o/l
      call day
C (line)
      go to 6

      End If
c
 5      continue
C First character not recognized

c Line was uninterpretable, so display menu:

 77     call menu
C Also display menu first time if no command

 6      continue
C get a new line and hop back up...
      if (exflag) go to 999
C DEBUG: Display remains of line after operations on it
C
C       iln = 1
c
C       do i = 1, icmln
c
C       if (line(i) .eq. 0) line(i) = O'32'
C control Z, displays as BLOT
c
C       if (line(i) .gt. ' ') iln = i
c
C       end do
c
C       WRITE(*,93) (line(i), i= 1, iln)
c
C 93    format(' ', <iln>a1, ': DTC: ',$)
       call dtcat(1,22)
       write(*,93)
 93     format(/,' DTC: ',$)
c ---   comlin = ' '
C Initialize w/ blanks
       read (*, 7, end=999)  comlin
 7      format(a)
       Do 750 n=1,80
       nnn=81-n
       comlen=nnn
       if(comlin(nnn:nnn).gt.' ')goto 751
       comlin(nnn:nnn)=char(0)
750    continue
751    continue

c Mark only stuff read from terminal
c (don't want command-input call to try to read terminal)

      line(min0(comlen+1, icmln)) = 0
C mark for old-style tests

      go to 1

 999    continue
C EXit, Quit, or ^Z
      stop
      end
C -h- dtcdatinc.for       Tue Jul  8 16:07:46 1986
      Subroutine dtcdtinc
C (Line,Incmod)

c routine to add or subtract sidereal units (days, weeks, months or years)

c incmod = 1 for day            (in COMMON)
c        = 2 for week
c        = 3 for month
c        = 4 for year

c format is
c  +nn or -nn : add/subtract nn default units
c  +/- nnu (u=d,w,m,y) to add/subt that unit

c output in defdat

      include comdtc.INC

      INTEGER*1 ln1, ll
      Character*1 ln1c
c ml is 14 long to allow refs out of bounds to l for no. days in month...

C length of months - Dec, Jan ... Dec, Jan
      Integer*4  l(12), ml(14)

      equivalence (l(1), ml(2)), (line, ln1)
      Equivalence(ln1,ln1c)
       include stmtfuncsp.for
       include comdtcd.inc

       Data ml /31, 31,28,31, 30,31,30, 31,31,30, 31,30,31, 31/
       include stmtfunc.for

c Begin code

      l(2) = 28
C Initialize (may have been changed below)

      isign=1
C Called only if + or - is first char of LINE
      if (ln1c .eq. '-')
     1   isign = -1

c now grab off digits...

      magn=0
C Initialize magnitude of value

      do (n = 2, icmln)
          ll = line(n)
          if (.not.( numeric(ll))) go to 5
C Exit first non-numeric
          magn = (magn * 10) + icvtbn1(ll)
      end do

      n = icmln
C This many numeric, no overflow???

 5      continue

      if (magn .eq. 0)
     1   magn = 1

      if (alpha(ll))
     1 then

          ll = ll .and. ucmask

c scan for d,w,m,y for units

          if (ll .eq. ichar('D'))
     1     then
        incmod=1
            else if (ll .eq. ichar('W')) then
        incmod=2
            else if (ll .eq. ichar('M')) then
        incmod=3
            else if (ll .eq. ichar('Y')) then
        incmod=4
            else
        n = n - 1
C Don't strip one we didn't use: alpha
          end if

        else

          n = n - 1
C Don't strip one we didn't use: non-alpha

      end if

      call shrink(n, ifnb, lnb)
C Shift LINE over

c magn now has magnitude, isign has sign and incmod has type of increment.

      if (incmod .le. 2)
     1 then
          inctyp = 1

c adjust weeks as being 7 * days and treat together

          if (incmod .eq. 2)
     1  magn = magn * 7

        else
          inctyp = incmod - 1

      end if

c inctyp is 1 for day or week, 2 for month, 3 for year

      if (inctyp .eq. 1)
     1  then
C Moving by days
          iddy = iddy + (isign * magn)

c loop point if we move forward

 100        if (iddy .gt. l(idmo))
     1     then

        lyd = 0

c account for leap years where february is 29 days long...

        if (islpyr(ibigyr) .and. (idmo .eq. 2))
     1      lyd = 1

        iddy = iddy - l(idmo) - lyd
        idmo = idmo + 1

        if (idmo .gt. 12)
     1    then
            idmo = 1
            ibigyr = ibigyr + 1
        end if

        goto 100

          end if

c loop point if we move back

 110        if (iddy .le. 0)
     1     then

c account for leap years. note ml is prev month so check def mo = 3

        lyd = 0
        if (islpyr(ibigyr) .and. (idmo .eq. 3))
     1      lyd = 1

        iddy = iddy + ml(idmo) + lyd
        idmo = idmo - 1
        if (idmo .le. 0)
     1    then
            idmo = 12
            ibigyr = ibigyr - 1

        end if

        goto 110

          end if

        else if (inctyp .eq. 2) then
C moving by months

          idmo = idmo + (isign * magn)

 200        if (idmo .gt. 12)
     1     then

        idmo = idmo - 12
        ibigyr = ibigyr + 1

        goto 200

          end if

 300        if (idmo .le. 0)
     1     then

        idmo = idmo + 12
        ibigyr = ibigyr - 1

        goto 300

          end if

        else if (inctyp .eq. 3) then
          ibigyr = ibigyr + (isign * magn)

      end if

      if (inctyp .ge. 2)
C months or years
     1 then
C Must check if we exceed month length

          if (islpyr(ibigyr))
     1     then
        l(2) = 29
            else
        l(2) = 28
          end if

          iddy = min0(iddy, l(idmo))
C force last day of month, if necessary

      end if

      idyr = mod(ibigyr, 100)
C Restrict to current 'century'

      end

C -h- menu.for    Tue Jul  8 16:02:05 1986
c-----------------------------------------------------------------------
C       Menu subroutine
C       part of Mitch Wyle's DTC program
C       Inputs:
c               None
C       Output:
c               display screen (see below)
C-----------------------------------------------------------------------
c

      SUBROUTINE menu

C       Declarations:
c

      include comdtc.INC
C Need ITERM
      include escdtc.INC
C       INTEGER*1 esc /27/
c       Integer*4  iterm/6/
       include comdtcd.inc
        include escdtcd.inc

C       Initialize:
c

c       iterm = 6
C       Output terminal unit number
c       esc = O'033'

c       call dtcat(1,1)
       write(*,1) esc,homescrn, esc,clrscrn
C       clear screen
 1      format($,4a, $)
c
       write(*,2) ' ', esc,dhdw1
C       double-height
 2      format($,3a,13X,'D T C   C o m m a n d s')
C       ..
c      write(*,2) ' ', esc,dhdw2
C       double-width
c
      write(*,3)
 3      format(/,1x,
     1  8x,'D [mmddyy]   -     Appointment Schedule for dd mm yy',/,
     2  8x,'W [mmddyy]   -     Week-At-A-Glance for week of dd mm yy',
     3  /,8x,'M [mmyy]     -     Month-At-A-Glance for mm yy',/,
     4  8x,'Y [yy]       -     Full Year calendar for yy',/,
     5  8x,'+ or - nnZ   -     Add/Subt nn Z (Z=D,W,M,Y): change date',
     5  /,
     6  8x,'N(cmd str)   -     Reverse display sense of M or W cmd',
     6     ' (free time)',/,
     7  8x,'L [mm]dd[yy] n -   Locate time (n * 30 mins.) free for mtg')
       Write(*,303)
303    format(
     8  8x,'hh:mm>hh:mm  -     Add or change appointments for hh:mm',/,
     9  8x,'EV (pseudo time) - Add or change EVening appointment',/,
     1  8x,'P [mmddyy]   -     Purge appointments prior to mmddyy',/,8x,
     2  'U [mmddyy] t1[>t2] <cmd> - Unschedule (cancel) appointments',/,
     3  8x,'X d1 t1 d2 t2 <cmd> - eXchange (reschedule) appointments',/,
     3  8x,'    (then execute <cmd> if present)', /,
     4  8x,'S [mmddyy]   -     Schedule multiple activity on mmddyy',/,
     4  8x,'    (Drops notices in all indirected users files also)',/,
     5  8x,'G [mmddyy]   -     File activities in multiple files',/,
     6  8x,'F FILENAME   -     Change default data file to Filename',/,
     7  8x,'I            -     Reset default date to today.',/,
     8  8x,'H or ?       -     Help!',/,
     9  8x,'Q or  EX     -     Exit')
C After all that
c
      return
c
      end
C -h- dtcidate.for        Tue Jul  8 16:02:23 1986
      subroutine dtcidate (imr, idr, iyr)
C Testing aid for DTC - allows for phony value of current date to be
c returned to caller, for verifying displays, etc
C Calling sequence - same as Fortran IDATE
c
      include comdtc.INC
      include dtcxidate.INC
      include defcentry.INC
       include escdtc.inc
      include comdtcd.inc
      include escdtcd.inc
c
      if (xim .eq. 0) then
C Assumes linker initializes to zero

          call date (xim, xid, xiy)
          if(xiy.gt.100)xiy=mod(xiy,100)
          xibgyr = icntry + xiy
          if(xibgyr.lt.100)xibgyr=xibgyr+1900
C Set long value

      end if

      imr = xim
      idr = xid
      iyr = xibgyr

      end
      subroutine dtcicomd
C Process "I" command: if no arguments, reset dummy IDATE to current date,
c else call dtcdatcvt to parse a date string, store those values in
c XIDATE common.

      include comdtc.INC
      include dtcxidate.INC
      include escdtc.inc
      include defcentry.INC

      INTEGER*1 ln1
      Character*1 ln1c
      equivalence (line(1), ln1)
      equivalence(ln1,ln1c)

      include comdtcd.inc
      include escdtcd.inc


      call shrink(1, ifnb, ilnb)
C Unload command character

      if (ln1 .eq. 0)
     1 then

          call date (xim, xid, xiy)
          if(xiy.gt.100)xiy=mod(xiy,100)
          xibgyr = icntry + xiy
          if(xibgyr.lt.100)xibgyr=xibgyr+1900
C Reset

c          xibgyr = icntry + xiy
C Set long value

          ibigyr = xibgyr
C Set values into common

          idmo = xim
          iddy = xid
          idyr = xiy

        else

          call dtcdatcvt (3)
C Parse string

          xim = idmo
C Set test values
          xid = iddy
          xiy = idyr

          xibgyr = ibigyr

      end if

      end
C -h- dtcrdappt.for       Tue Jul  8 16:02:38 1986
      subroutine dtcrdappt (eofflg, indflg)

c search through appointment files for entries matching range of hash values.
c opens files if EOFFLG set on entry. INDFLG controls whether indirect files
c should be opened as encountered, and whether caller wants to look at indirect
c entry or not:

c       INDFLG
c         -1    No processing @
c          0    Normal processing
c         +1    Return before opening @

c       EOFFLG  Entry                   Exit
c         -1    Initialize              EOF return
c          0    Normal re-entry         Normal return, valid entry
c         +1    Open @ file             Return for @ filename found

c Processes both old- and new-format files
c       Old: yymmddhhh appt (possibly no blank between HHH & APPT)
c       New: yyyymmddhhhh appt

c Created 19850802, CG, using some code removed from DAY subroutine

c      implicit none

      Integer*4  eofflg, indflg
C i/o, i only

      include comdtc.INC
      include apptdtc.INC
      include defcentry.INC
C Default century for old format
      include escdtc.inc
      character*1 nullch
C Old old files had trailing NULs
      include stmtfuncsp.for
      Integer*4  i, ij, lth, istrend, nunit

      Data nullch/0/
      include comdtcd.inc
      include escdtcd.inc
      include stmtfunc.for

c Begin code

c ***   type 950, irqhash
c 950   format(2z9.8)

      if (eofflg .lt. 0)
C Start scan
     1 then

          nunit=1
          close(1)
          Open (unit=nunit, file=FNc(1:fnsz),
     1     status='OLD',action='READ',
     1    form='FORMATTED', err=99)

          eofflg = 0
c ***   type  *, ' Opened file'
      end if

c loop back up here to continue reading and processing input file:

      do while (eofflg .ge. 0)

 900    format( a)
C Read all
 901    format(3i2, i3)
C Decode old
 902    format(i4, 2i2, i3)
C Decode new

          if (eofflg .gt. 0)
     1     then
C must open indirect file

        eofflg = 0

c ***   type 951, work(istart)
c *** 951       format (' ', a)
        Do (nnn=1,80)
         ilst=81-nnn
         if(workstr(ilst:ilst).gt.' ') goto 952
c find index of end string (last nonspace char)
        End Do
952     continue
        nunit = 2
        close(2)
        Open (unit=nunit, file=workstr(istart:ilst), status='old',
     1        form='formatted', action='READ',
     2        err=1067)

          end if

          read (nunit, 900, end=400,err=400) workstr
c find lth now by hand
c assume 80 char work array max
         do 705 i705=1,80
         lth=81-i705
         if(workstr(lth:lth) .gt. ' ') goto 706
         workstr(lth:lth)=nullch
705      continue
706      continue
c ***   type  *, ' ', workstr
C Look for non-blank
C & non-null
          do (i = min0(lth, iwrkln), 1, -1)
        if ((workstr(i:i) .ne. ' ')
     1      .and. (workstr(i:i) .ne. nullch))
     2  go to 10
C Break
          end do

          i = 1
C All blank entry ???

 10         lth = i

c String is filled with blanks regardless of length of record

          if (chnumeric(workstr(10:10)))
     1     then
C new format
        read(workstr, 902, err=30) ihy, ihm, ihd, iht
        istart = 12
C Index of first valid character
c ***   type  *, ' New format'

            else
C       Old format

 30             continue
C       Retry old
        read(workstr, 901, err=300) ihy, ihm, ihd, iht
        ihy = ihy + icntry
C       Insert current century

        istart = 10
C Assume old, old format

c ***   type  *, ' Old format'

          end if
C (workstr(10) is numeric)

          if (workstr(istart:istart) .eq. ' ')
     1  istart = istart + 1
C Index of first valid character

          iwkln = max0((lth - istart) + 1, 1)
          istrend = (istart + iwkln) - 1
          iaptln = max0(min0(iwkln, icmln), 1)

          if (ihm .eq. 99)
     1     then

        ihy = 9999
C set all fields
        ihd = 99
        iht = 999

        if ((indflg .ge. 0) .and. (nunit .eq. 1))
     1    then

            call fnscan(work(istart), icmln - istart + 1,
     1                  iwkln, ij)
C Common code to check filename

            if (ij .ne. 0)
     1        then
C Skip if no file

c ***   type *, ' IJ = ', ij
                eofflg = 1

                if (indflg .gt. 0)
     1            then

                    apptstr = workstr(istart:istrend)

                    return
C DAY, STRIP want a look

                end if
C Found 1

            end if
C non-null file-name

        end if
C valid place for indirect

            else
C not filename flag in record

        irchash = ihymd(ihy, ihm, ihd)
C Compute hash for record

c ***   type 950, irchash

        if ((irchash .ge. irqhash(1))
     1      .and. (irchash .le. irqhash(2)))
     2    then
C Found record within range, exit

            apptstr = workstr(istart:istrend)

c ***   type *, ' Returning'
           return
C Break out of loop
400                continue
C no more appointments left in file.
c ***   type  *, ' EOF'
           if (nunit .eq. 1)
     1        then
C Which file were we reading?
               eofflg = -1
C real end of file
             else
1067                   close (2)
C Error opening indirect file
               nunit=1
           end if
C Which unit had EOF
       end if
C Hash range test
         end if
C type of record
300        continue
C Error decoding y/m/d/t fields
      end do
C Read next line from current file
      close (1)
C Close first-level
99     continue
C Failed first open
      end
C -h- dtcmthnam.for       Tue Jul  8 16:03:02 1986
      SUBROUTINE dtcmthnam (im,monthn)
c-----------------------------------------------------------------------
C       Subroutine dtcmthnam (formerly GABY)
C       Part of Mitch Wyle's DTC program
C       return a string corresponding to the month number
c       Month number contained in IM.  Send back string in MONTHN.
c       (JANUARY for 1, etc.)
C-----------------------------------------------------------------------
C       Modified 850315 - Center month names in table, use mixed case - CG
c       Modified 850802 - Renamed DTCMTHNAM

C       Declarations:
c
      INTEGER*1 monthn(9)
c ***   character*9 monthn
C Can't use, char params expect descriptor

C       Table of month names and numbers (centered, even lengths biased left):
c

      INTEGER*1 months(9,14)
      character*9 monthch(14)

      equivalence (months, monthch)
C       Select the right month and fill monthn with it:
      Data monthch/           'December ',
     1 ' January ', 'February ', '  March  ', '  April  ',
     2 '   May   ', '  June   ', '  July   ', ' August  ',
     3 'September', ' October ', 'November ', 'December ',
     4 ' January '/

c

C ALLOW FOR OVERFLOWS...
      IMM=IM+1
c ***   monthn = monthch(imm)
C String assignment
c
      Do (i=1,9)
C byte-at-a-time
          Monthn(i) = months(i,imm)
      end do

c       All done.

      end
C -h- dtcalcdow.for       Tue Jul  8 16:03:26 1986
        SUBROUTINE dtcalcdow(ib,il,im,iyx)
c-----------------------------------------------------------------------
C       DTCALCDOW subroutine
C       part of Mitch Wyle's DTC program
C       Inputs:
c               im      -       month (number 1-12)
c               iy      -       year  (number 0-9999)
C       Outputs:
c               ib      -       integer corresponding to day of week
c                               on which the month begins (1-7)
c               il      -       length of the month in days
C       Modified 850117 by CG because it thought New Years 1985 was on Monday
c               when it really was on Tuesday (not counting intervening
c               leap years between 1982 and current as having 366 days).
c       Modified 850724 by Glenn Everhart to work for years between 1900
c               and 1982 (formerly thought all intervening years started
c               on Friday)
c       Modified 850726 by CG to simplify days-since-base calculation.
c               NOTE: Has been reworked to calculate all dates AS IF
c               the Gregorian Calendar had been in effect since AD 1,
c               and that the Gregorian correction for 100 and 400
c               will be valid indefinitely (the 1928 Episcopal
c               Book of Common Prayer indicates this is valid at least
c               until AD (or CE) 8400, but I don't think I, or anybody
c               reading this code within the forseeable future will be
c               around to verify whether it does or doesn't!), see note
c               just before IDAYS computation.  It will also try to compute
c               if a negative year is input (i.e., BC) but probably won't be
c               valid since there was no year zero.  If any calendar phreak
c               wants to figure it out for the Julian calendar, have fun,
c               just keep in mind that the Gregorian superseded the Julian
c               at different times and in different ways in different localities
c               (October 4, 1582 was followed by October 15 in Catholic
c               countries, and another "long sleep" occurred in September 1752
c               in English-speaking realms, but apparently in Sweden
c               the change was effected by omitting Leap Years
c               until the calendar got back in sync
c               (there is a story of a man who didn't celebrate his first
c               birthday until he was sixty years old, leaving Frederic
c               of Pirates of Penzance with little to complain about)
C               Russia, Romania, Greece and Turkey did not convert until
c               the twentieth century.
C               P.S.: 4th parameter (input year) is no longer modified.
C       Modified 850729 by CG - Get rid of loop that added number of days of
c               each month --- why sum a sequence of constants?
c       Modified 850802 by CG - renamed from DANY to DTCALCDOW, removed
c               default century and previously commented-out code
c       Modified 850809 by CG - Insure IB output in range 1..7: negative values
c               (from negative year input) caused DTCDSPMTH to zap its
c               character arrays and display some verrry strange-looking months
C-----------------------------------------------------------------------
c
c       Declarations:
c Base value for IDAYS, day-of-week for January 1, AD 1
C
      parameter (idow = 2)
      Integer*4  im
C       Julian Month
      Integer*4  iyx, iy
C       Julian Year
      Integer*4  lpyear
C       Define additive variable
       include stmtfuncsp.for
c Array of months and number days
       Integer*4 months(12)
C in each one
c array of months containing d/o/w
       Integer*4  bomdow(12)
C of first day of month

      Data months
     1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
C in each one

c array of months containing d/o/w
      data bomdow
     1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 /
C of first day of month
      include stmtfunc.for
C Need ISLPYR function
c
c Begin code
c
      iy = iyx
C Copy parameter
c Take care of leap years:
      lpyear = 0
C Assume "common" year
      if (islpyr(iy))
     1 then
          months(2) = 29
C length of February in leap year
          if (im .gt. 2) lpyear = 1
C Add one to BOM DOW after Feb
        else
          months(2) = 28
C .. "common" year
      end if

c Rather than add up all of the days since January First, AD 1
c (which would have been a Monday had the Gregorian calendar been in effect then),
c we note that the day of week of 1 January advances by 1 day per year,
c plus another day the year AFTER a leap year, etc, therefore just add
c values of years, leap years, century years, etc, modulo 7, to figure out
c day of week of the month we are interested in.

      itemp = iy - 1
C not including current year
C Day of week of 1/1/0001
C plus number of years
C plus number of leap years
C less even hundreds
C but add back even four hundreds
C plus day of week for BOM
      idays = idow
     1  + itemp
     2  + (itemp/4)
     3  - (itemp/100)
     4  + (itemp/400)
     5  + bomdow(im)
     6  + lpyear
C plus 1 for March or later in leap year

      ib = mod ( idays , 7 )
C Find day of week 0:6
      if (ib .le. 0) ib = ib + 7
C In case IY was negative (Sun is day 1)
      il = months(im)
C Length of the current month

      end
C -h- dtcdspmth.for       Tue Jul  8 16:03:45 1986
      SUBROUTINE dtcdspmth (ib,il,xoff,xspa,YOFF,yspa)

c-----------------------------------------------------------------------
C       DTCDSPMTH month printing subroutine (formerly MISCHY)
C       part of Mitch Wyle's DTC program
C       Inputs:
c               ib      -       begining day of the week
c               il      -       length of month in days
c               xoff    -       offset for x coordinate
c               xspa    -       number of spaces to skip between numbers
c               yoff    -       offset for y coordinate
c               yspa    -       number of lines to skip between lines
C       Output:
c               display screen (see below)
C       Modified 850301, CG - write full line at a time, rather that each date
c       Modified 850802, CG - Renamed from mischy
C-----------------------------------------------------------------------
c

c       Declarations:

      Integer*4    ib
C       beginning day of the week
      Integer*4  il
C       length of month in days
      Integer*4  xoff
C       x offset
      Integer*4  xspa
C       number of spaces between numbers
      Integer*4  yoff
C       y offset
      Integer*4  yspa
C       number of lines to skip between lines

      include comdtc.INC
C Need ITERM
      include escdtc.INC

      Integer*4  ix
C       x coordinate of where to put day
      Integer*4  iy
C       y coordinate of where to put day
      Integer*4  ip
C       the day of the week for date in hand
      Integer*4  ixo
C       xoff + 1

c numbers as characters
      Integer*2  nums(31)
      Integer*2  wknums(7)
c 1      format('+',6(a2,<ix>x),a2)
      Character*1 nmfmt(18)
      Character*2 nmff
      Character*18 nmfm
      Equivalence(nmfm,nmfmt(1)),(nmfmt(10),nmff)
      Data nmfm/'($,6(1A2,01X),1a2)'/
      Data nums
     1 /      ' 1', ' 2', ' 3', ' 4', ' 5', ' 6', ' 7', ' 8', ' 9',
     2  '10', '11', '12', '13', '14', '15', '16', '17', '18', '19',
     3  '20', '21', '22', '23', '24', '25', '26', '27', '28', '29',
     4  '30', '31'/

      include comdtcd.inc
      include escdtcd.inc
C To contain copies of above, or blanks

c Begin code

      do (i = 1, 7)
C       One week's worth
          wknums (i) = '  '
C       initialize
      end do
      ip = ib
      ix = xspa + 1
C       Used in format # 1
      ixo = xoff + 1
      iy = 4 + YOFF

c Now write month out to screen, one week at a time:

      Do (i = 1, il)

          wknums(ip) = nums(i)
C       Get day as character
          If ( ip .eq. 7 )
C       is it Saturday again?
     1     then
        call dtcat(ixo,iy)
C       Position cursor for line
        write(nmff,110)ix
        write(*,nmfm)wknums       
c        write (*,1) wknums
C       Write filled array
        ip = 1
C       reset day to Sunday.
        iy = iy + 1 + yspa
C       move down one line
            else
        ip = ip + 1
C       increment day number
          End If

      end do

      if (ip .ne. 1)
C       Partial buffer remains
     1 then

          call dtcat(ixo,iy)
C       Position cursor
c          write (*,1) (wknums(i), i = 1, ip - 1)
       write(nmff,110)ix
110    format(i2.2)
       write(*,nmfm)(wknums(i),i=1,ip-1)       
1      format($,a2,1x,$)
        Write(*,223)
223     format(/,1x)
c emit trailing crlf...
cC       Write rest of array
       end if

c 1      format('+',6(a2,<ix>x),a2)
      end
C -h- dhelpvax.for        Tue Jul  8 16:04:30 1986
c-----------------------------------------------------------------------
C       Help subroutine
C       part of Mitch Wyle's DTC program
C       Inputs:
c               None
C       Output:
c               display screen (see below)
C-----------------------------------------------------------------------
c

      SUBROUTINE dhelp

      include comdtc.INC
      include escdtc.INC
c

c       Integer*4  iterm/6/
c       INTEGER*1 esc/O'033'/
        INTEGER*1 buf(79)
         include comdtcd.inc
         include escdtcd.inc

C       Initialize:
c

c       iterm = 6
C       Output terminal unit number
c       esc = o'033'

      call dtcat(1,1)
       write(*,91) esc,homescrn, esc,clrscrn
C       clear screen
       write(*,1) ' ', '    D T C  -  Desk Top Calendar'
c      write(*,1) ' ', esc,dhdw2, '    D T C  -  Desk Top Calendar'
c
 1      format(40a)
 91     format($,4a, $)

      Open (unit=1,file='DTC.HLP',action='READ',form='FORMATTED',
     1  status='OLD', err=9)

      Do (i=1, 22)
          Read(1,4,end=5) buf
        do 301 n=1,78
        ibln=79-n
        if(buf(ibln).gt.32)goto 302
        buf(ibln)=0
301     continue
302     continue
          if (ibln .ne. 0) then
        write (*,6) (buf(j), j=1,ibln)
          else
        write (*,6)
          end if
       end do
c
 4      format(100a1)
 6      format(1x,100a1)
c
 5      close(unit=1)
C Read end-of-file
       return
c
 9      write(*, 99)
 99     format(' Help file C:DTC.HLP not found')
	Return
       end
C -h- day.for     Tue Jul  8 16:04:45 1986
c-----------------------------------------------------------------------
C       Daily Appointment subroutine
C       part of Mitch Wyle's DTC program
C       Input:
c       line - 72 INTEGER*1s;  Format: D [mmddyy [hh:mm>HH:MM [appointment]]]
C       Output:
c               display screen (see below)
C-----------------------------------------------------------------------
C       Modified 850314, CG, to write day-of-week to daily-appointment screen,
c          and note current time if current day displayed (reverse video)
c       Modified 19850802, CG, to write full date as well, and handle both new-
c          and old-format appointment files.
c       Modified 851218, CG: change default range of appointment from whole day
c          to 8:00 only
C       Modified 860220, CG: Check for duplicate appointment times,
c          move and flag them

      SUBROUTINE day
C (line)

c       Declarations:

      include comdtc.INC
      include apptdtc.INC
      include escdtc.INC

      character*100 apstr
      INTEGER*1 appnt(icmln)
C       appointment string
      INTEGER*1 temp(2), ll, ln1, ap1
      Character*1 ln1c
C       temporary string converting array

      INTEGER*1 blot
C       ^Z, for entry from display

      Integer*4    id, idr
C       Julian Day
      Integer*4  im, imr
C       Julian Month
      Integer*4  iye, iyr
C       Julian Year
      Integer*4  idx, imx, iyx, isx
C copies for calling DANY
      integer*1 ibsp
      Integer*4  eofflg

C uses A6 fmt
C 'day' is in format
      real*8 daylist(7)
      character*9 mthlist(12)

      character*22 dupl
C only 3:22 used
      INTEGER*1 dupb(22)
      Integer*4  iscnds
      equivalence (line, ln1), (apstr, appnt),(apstr, ap1),
     1  (dupl, dupb)
      character*1 blotc
      equivalence(blot,blotc)
      Equivalence (ln1,ln1c)
       include stmtfuncsp.for
       data blotc/'_'/
        include comdtcd.inc
        include escdtcd.inc

      Data daylist / '   Sun', '   Mon', '  Tues',
     1 'Wednes', ' Thurs', '   Fri', ' Satur' /
      Data mthlist
     1 /'  January', ' February', '    March', '    April',
     2  '      May', '     June', '     July', '   August',
     3  'September', '  October', ' November', ' December'/


      include stmtfunc.for

c       Initialize:

      dupl = '##'
C Init for duplicate check

c leave = or *
      if ((ln1 .and. ucmask) .eq. ichar('D'))
     1    call shrink(1, ifnb, lnb)

      call dtcdatcvt(3)
C Pick off a date value

      im=idmo
      id=iddy
      iye=ibigyr
      call dtcalcdow (isx, imx, im, iye)
C Get day-of-week for B/O/M

      idx = mod (id + isx - 2, 7) + 1
C Calc current d/o/w

      call dtcidate(imr, idr, iyr)
C Get today's date

C if current = today,
C flag current time
      if ((im .eq. imr) .and.
     1   (id .eq. idr) .and.
     2   (iye .eq. iyr)) then
C Displaying current day
          Call time(iscnds)
          scnds=iscnds
          scnds = amax1(scnds, 28801.)
C Get current time (>8 AM)
          ihalf = mod(ifix(scnds/1800.), 48)
C current half-hour (orig 0)
          ihour = ihalf/2
C       Current hour
          ihalf = ihalf - (ihour*2)
C       0 or 1 for half-hour

       else
          ihour = 0
C       Set non-match value
      endif

c ************************** Move the cursor to top of screen and clear it,
c ************************** set up appointments display:
      write(*,4) esc,homescrn, esc,clrscrn
 4      format($, 4a, $)

      write(*,5,err=598) 
     1 daylist(idx), mthlist(im), id, ibigyr
 5      format(1x,'Schedule - ', a6,'day, ', a9, i3, ',', i5)
c      write(*,5) ' ', esc,dhdw2,
c     1 daylist(idx), mthlist(im), id, ibigyr
598     continue

      Do (i=8,16)
          If ( i .gt. 12 ) then
        j = i - 12
          Else
        j = i
          End If

          if (i .ne. ihour) then
C Check for highlighting
        write(*,6) j
        write(*,7) j
          else
C must be current hour
        if (ihalf .eq. 0) then
C Check which half
            write(*,96) esc,revattr, j, esc,resetvattr
            write(*,7) j
        else
            write(*,6) j
            write(*,97) esc,revattr, j, esc,resetvattr
        endif

          endif
      end do

 6      format(1x,i2,':00   -')
 7      format(1x,i2,':30   -')
 96     format (2x, 2a, i2,':00', 2a, '   -')
 97     format (2x, 2a, i2,':30', 2a, '   -')

      if (ihour .ge. 17) then
C Highlight 'Evening' line
          write(*,98) esc, esc
      else
C Includes display other than today
          write(*,9)
      end if

 9      format(1x, 'Evening -', /, x, 75('='))
 98     format(1x, a, '[7m Evening', a, '[0m-', /, x, 75('='))

c ******************* Screen has now been displayed,
c ******************* now check rest of line for time and appointment

      if (ln1 .ne. 0) then
C More characters available?

          iht = 80
C Default is 8:00
          ihmx = iht
C (only 1 entry)
          call dtctimcvt(iht, ihmx)
C Decode time value if present

          ihh1 = (iht+2)/5
C Adds 1 if trailing 3
          ihh2 = (ihmx+2)/5
C Result is 16 to 35
          idmx = min0(max0(ihh2-ihh1, 1), 20)
C 8:00>6:00
          iht = min0(iht,173)
C Limit entry time (DTCTIMCVT lim is 180)

c Note: range of h1:00>h1:30 is considered only one scheduling interval,
c similarly h(1)>h(2) is an even number, ending just before h(2),
c computation forces at least one for interval h1:00>h1:00

          ifnb = 0
          lnb = 0
          ivx = 0
          ap1 = 0
C Clear appointment string

          do (i = 1, icmln)

        ll = line(i)
        appnt(i) = ll

        if (ll .eq. 0) go to 6789
C done

        ivx = i
C Save current length

          end do

c               Was there an appointment string input?
c               If so, put it in file, and display it on screen.
c               If not, move cursor to correct time on screen,
c               then input the appointment, put in file and re-display it.

 6789       If (ap1 .eq. 0) then
C Empty appointment string

        iy = ihh1 - 13
C Vertical position for half hour
c amiga fixup ... iy is 1 less
        iy = iy-1
c end amiga fixup...
        ix = 11
        call dtcat(ix,iy)
        ibsp=8
        write(*, 987) blot,ibsp
C write blot, backspace
 987            format ($, 2a1, $)
        read(*,13,END=914,err=914) workstr
 13             format(a)
      do 305 nnn=1,80
      lapp=81-nnn
      if(workstr(lapp:lapp).gt.char(32))goto 306
      workstr(laPP:LAPP)=char(0)
305   continue
306   continue
c copy appointment for use later...

        ifnb = 0
        lnb = 0
        ivx = 0

        Do (i = 1, lapp)

            ll = work(i)
C fetch character

            if (ll .gt. 32) then
                if (ifnb .eq. 0) ifnb = i
C Flag first non-blank
                lnb = i
C Flag last non-blank

            end if

            if (ifnb .ne. 0) then
C Copy after first n/b
                ivx = ivx + 1
                appnt(ivx) = ll
            end if

        end do

        if (ifnb .eq. 0) go to 914
C Nothing on read either

          End If

          ivx = min0(ivx, iaptlim)
C ivx = length of string

C  If we are using the 'S' command, add meetings to the indirected files ONLY,
C  not to the current (control) file.

          if (ctlfg .ne. 1) then
C Add appointment if D or G

        close (1)
C Insurance
        Open ( unit=1,file=FNc(1:fnsz)
     1  ,status='UNKNOWN',form='FORMATTED',
     1  position='append',err=9876)

        ihtxx=iht
        do (ixx = 1, idmx)

            write(1,14,err=597) iye,im,id,ihtxx,apstr(1:ivx)
597    Continue
            if ((ihtxx/10)*10 .eq. ihtxx)
     1        then

                ihtxx=ihtxx+3
C IHT is even hour, go to next half hour

              else

                ihtxx=ihtxx+7
C IHT is a half hour ... make up to next hour

            end if

        end do

 14             format(i4.4,2i2.2,i3.3,x,a)

 9876           close(1)

          End If

      else
C Empty line (no appointment to add)
 914        idmx = 0
C Use as flag for display only

      end if

      eofflg = -1
C Request OPEN
      prveof = 0
C Set for DO WHILE

      lookind = 0
      if (ctlfg .ne. 0) lookind = 1
C Set for looking at filenames

      irqhash(1) = ihymd(iye, im, id)
C Set match for file scan
      irqhash(2) = irqhash(1)
C One day only
      IHTsav=IHT
c Iht clobbered by dtcrdappt
      do while (prveof .ge. 0)

         call dtcrdappt(eofflg, lookind)

          if (eofflg .eq. 1)
     1     then
C Returned with filename string

c on scheduling multiple dates via S or G functions, use this occasion to
c add the record to everyone's calendar file.

        close(2)
        Do (nnn=1,90)
        nnm=101-nnn
        If(Workstr(nnm:nnm).ge.char(32))Goto 963
c find last nonblank char in string
        End Do
963     Continue
        Open (unit=2, file=workstr(istart:nnm), status='UNKNOWN',
     1      form='FORMATTED',
     2      position='APPEND', err=1119)

c        ihtxx=iht
        ihtxx=ihtsav
        do (ixx = 1, idmx)
            write(2,14,err=596)iye,im,id,ihtxx,apstr(1:ivx)
596     Continue
            if ((ihtxx/10)*10 .eq. ihtxx) then
                ihtxx=ihtxx+3
C iht is an even hour ... add the half hour
            else
                ihtxx=ihtxx+7
C iht is a half hour ... make up to next hour
            end if

        end do

 1119           close(2)

c Display appointment if it matches current date

          else If (eofflg .eq. 0)
     1     then

        iy = min0(max0((((iht+2) / 5) - 13), 3), 22)

c  Amiga fixup -- iy is 1 less
        iy=iy-1
c end Amiga fixup

C Compute vertical posn
C Have we been here before
        if (dupb(iy) .eq. 32)
     1    then
C No
            dupb(iy) = '-'
C Flag it
          else
C Duplicate time stamps, find substitute
            do (ix = iy-1, 3, -1)
C Search backward first
                if (dupb(ix) .eq. 32)
     1            then
                    iy = ix
C Save replacement
                    dupb(iy) = 'v'
C Point to where it should go
                    go to 3141
C >>> BREAK <<<
                end if
            end do
            do (ix = iy + 1, 22)
C Search forward
                if (dupb(ix) .eq. 32)
     1            then
                    iy = ix
C Save replacement
                    dupb(iy) = '^'
C Point to where it should go
                    go to 3141
C >>> BREAK <<<
                end if
            end do
            dupb(iy) = blot
C Flag it
        end if

 3141           ix = 2
C first char to print
        if (appoin(1) .ne. 32)
     1    then
            ix = 1
C '12:00   - Appointment'
          else
            if (iaptln .le. 1)
     1       then
                appoin(2) = blot
C Display BLOT for empty entry
                iaptln = 2
            end if
        end if

        kk = min0(iaptln, iaptlim)

        call dtcat(8,iy)
C Set cursor position

C flag + text
        write(*,300) dupb(iy), ' ', apptstr(ix:kk),
     1      esc,'[K'
C Erase EOL
 300            format($, 5a, $)

          End If
C eofflg .ge. 0

          prveof = eofflg
C Show what happened

      end do
C while (prveof)
      write(*,367)
367    format('  ')
d      write(4,4203)
d4203  format(' Day .. returning')
d      call dely
      call dtcat(1,22)
      Return
      end
C -h- month.for   Tue Jul  8 16:05:05 1986
c-----------------------------------------------------------------------
C       Month-at-a-glance subroutine
C       part of Mitch Wyle's DTC program
C       Input:
c               line    -       72 INTEGER*1 string;  Format: M [dd[19[yy]]]
C       Output:
c               display screen (see below)
C  Line
c     1 Prevmonth                       Nextmonth
c     2 SMTWTFS                           SMTWTFS
C   3-8 Calendar                         Calendar
c  9/10 Y e a r         M o n t h         Y e a r
c    11               S M T W T F S
c 13-23              C a l e n d a r
C Lines 9/10 are double-height/double-width
c Odd lines 11-23 are double-width
c Even lines 10-22 are blank
C-----------------------------------------------------------------------
C       Modified 850318, several changes- CG
c               Display today's date in current, prev or next month
c                 in reverse video
c               Write out >>> only <<< non-blank flags (*'s)
c               Speed-up of month display (actually in dtcdspmth subr)
c               Months mixed-case and centered (GABY)
c       Modified 850809 - display IBIGYR both sides of month, DH/DW

      SUBROUTINE month
C (line)

c       Declarations:

      include comdtc.INC
      include apptdtc.INC
      include escdtc.INC

      INTEGER*1 TEMP
      Dimension TEMP(4)
C       temporary string converting array
      CHARACTER*4 TMPP
      EQUIVALENCE(TMPP,TEMP(1))
      Integer*4    id
C       Julian Day
      Integer*4  im
C       Julian Month
      Integer*4  iy
C       Julian Year

      Integer*4  prveof, eofflg

c string month name
      INTEGER*1 monthn(9),
     1 lmonth(9)
c Entries true if lenght of name is even
      logical*1 lmneven(12)
c Entries true if length of name is odd
      logical*1 lmnodd(12)

      INTEGER*1 out(79)
C       The output string and * array
        INTEGER*1 rchr
C       Flag set (or reset) character
      INTEGER*1 ln1
C       Same as line(1)
       include stmtfuncsp.for
      equivalence (line, ln1)
      Character*41 lxfmt
      Character*2 lxfixx,lxfixy
      Character*1 lxfc(41)
      Equivalence(lxfc(1),lxfmt)
      Equivalence (lxfixx,lxfc(14)),(lxfixy,lxfc(27))
      include comdtcd.inc
      include escdtcd.inc
c 8      format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $)
c      write(*,8) ' ', esc,dhdw2, temp, monthn, temp
c
      data lxfmt/'(7x,4(a1,2x),01x,9(2x,a1),01x,4(2x,a1),$)'/
      data lmneven/
     1 .false., .true., .false., .false., .false., .true.,
     2  .true., .true., .false., .false., .true.,  .true./
c Entries true if length of name is odd
      data lmnodd
     1 /.true., .false., .true., .true.,  .true., .false.,
     2 .false., .false., .true., .true., .false., .false./

      include stmtfunc.for

c Trim off the M from command line:
      if(ln1.gt.96)ln1=ln1-32
      if ((ln1 ) .eq. Ichar('M'))
     1 call shrink(1, ifnb, lnb)

      call dtcdatcvt(2)
C Decode date string

      im=idmo
C Pick up result from common
      id=iddy
      iy=ibigyr

      call dtcidate(irm,ird,iry)
C Real month,day,year, for display highlight

c Move the cursor to the top part, clear the screen

      write(*,600) esc,homescrn, esc,clrscrn
 600    format ($, 4a, $)
       Call Dtcat(1,1)
c Now start building the output string: (out)

      WRITE(TMPP,20,ERR=11)IY
C       encode(4, 20, temp, err=11) iy
 11     continue
 20     format(i4)

c Calculate nominal prev, next month numbers

      lm = im - 1
      ly = iy
      nm = im + 1
      ny = iy

      If ( im .eq. 1 ) then

          lm = 12
          ly = iy - 1

      else If ( im .eq. 12 ) then

          nm = 1
          ny = iy + 1

      End If

C PRINT PREVIOUS MONTH
      call dtcmthnam(lm,lmonth)

C PRINT NEXT MONTH CALENDAR AT TOP
      call dtcmthnam(nm,monthn)

C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS
      ix = 3
      if (lmneven(lm)) ix = ix + 1
      call dtcat(ix, 1)
      write(*,6) lmonth
      ix = 61
      if (lmneven(nm)) ix = ix + 1
      call dtcat(ix, 1)
      write(*,6) monthn
 6      format ($, 9(1a1, 1x))
      call dtcat(1, 2)
      write(*,7)
 7      format($,'Su Mo Tu We Th Fr Sa',
     1  T60,'Su Mo Tu We Th Fr Sa')
c       call dtcat(35, 7)
C Center year above cur month
c       write(*,96) temp
c 96        format ('$', 4(x, a1))

c Now display last month, header for this month, and next month:

c Last month to upper-left corner of screen

      call dtcalcdow(ib,il,lm,ly)
      call dtcdspmth(ib,il,0,0,-1,0)
      If ((irm .eq. lm) .and. (iry .eq. ly)) then
C today in rev video
          irdw = mod (ird + ib - 2, 7)
C Day of week (orig 0)
          irwk = (ird + ib - 2)/7
C Week in month (orig 0)
          call dtcat ((irdw*3) + 2, irwk + 3)
          write (*,684) esc,revattr, ird, esc,resetvattr
      end if

c Next month to upper-right corner of screen

      call dtcalcdow(ib,il,nm,ny)
      call dtcdspmth(ib,il,58,0,-1,0)
      If ((irm .eq. nm) .and. (iry .eq. ny)) then
C today in rev video
          irdw = mod (ird + ib - 2, 7)
C Day of week (orig 0)
          irwk = (ird +ib - 2)/7
C Week in month (orig 0)
c added 1 to x coord in dtcat for amiga fixup here and just above.
          call dtcat ((irdw*3) + 60, irwk + 3)
          write (*,684) esc,revattr, ird, esc,resetvattr
      end if

c               display big banner header name of this month:

c       call dtcat(ix,9)
      call dtcat(1,9)

      call dtcmthnam(im,monthn)

      ix = 11
      if (lmneven(im)) ix = ix + 1
      ixx = ix - 9
      ixy = 14 - ix
      ixx2=ixx+ixx
      ixy2=ixy+ixy
c double spaces for single-wide char screen to emulate dbl wide char screen
       write(lxfixx,2220)ixx2
2220   format(i2.2)
       write(lxfixy,2220)ixy2
       write(*,lxfmt)temp,monthn,temp
c       write(*,225)temp
c 8      format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $)
c      write(*,8) ' ', esc,dhdw2, temp, monthn, temp

c Now print the week day headers for this month, and the days for this month:

      call dtcat(1,11)
      write(*,10)
 10     format($,
     1 '  S u n      M o n     T u e s     W e d s   T h u r s',
     1 '       F r i       S a t')
c          x     x     x     x     x     x     x     x

C Mark double-width lines
c      write (*,138)
c     1 esc,'[13H', esc,dwide,
c     2 esc,'[15H', esc,dwide,
c     3 esc,'[17H', esc,dwide,
c     4 esc,'[19H', esc,dwide,
c     5 esc,'[21H', esc,dwide,
c     6 esc,'[23H', esc,dwide
 138    format ($, 24a, $)
c
        call dtcalcdow(ib,il,im,iy)
        call dtcdspmth(ib,il,8,8,9,1)
C For single-width
c        call dtcdspmth(ib,il,1,3,9,1)
C For double-width
c
        If ((irm .eq. im) .and. (iry .eq. iy)) then
C today in rev video
c
          irdw = mod (ird + ib - 2, 7)
C Day of week (orig 0)
          irwk = (ird + ib - 2)/7
C Week in month (orig 0)
          call dtcat ((irdw*11)+9, (irwk*2)+13)

          if (id .eq. ird) then
        write (*,684) esc,'[4;7m', ird, esc,resetvattr
          else
        write (*,684) esc,revattr, ird, esc,resetvattr
        go to 685
C And show looking-at date
          end if

 684            format($, 2a, i2, 2a, $)

       else

 685        irdw = mod (id + ib - 2, 7)
C Day of week (orig 0)
          irwk = (id + ib - 2)/7
C Week in month (orig 0)
          call dtcat ((irdw*11)+9, (irwk*2)+13)

          write (*,684) esc,'[4m', id, esc,resetvattr

      end if

      if (rdspfg .eq. 0) then
        rchr='*'
        out(1) = ' '
      else
        rchr=' '
        out(1) = '*'
      end if

      Do (i= 2, 31)
C set the out array to all blanks:
      out(i) = out(1)
      end do

c Now for files I/O to put *'s on days with appointments:

      irqhash(1) = ihymd(iy, im, 1)
C Want entries for
      irqhash(2) = ihymd(iy, im, 31)
C current month

      eofflg = -1
      prveof = 0

      do while (prveof .ge. 0)

          call dtcrdappt(eofflg, 0)
          if (eofflg .ge. 0) out(ihd) = rchr
          prveof = eofflg

      end do

c Have now accumulated all info about current month,
c go back and flag appropriate days

      iy = 13
      ip = ib - 1

      Do (i=1,il)

          ip = ip + 1
C       increment day number
          If ( ip .gt. 7 ) then
C       is it Sunday again?
        ip = 1
C       reset day to Sunday.
        iy = iy + 2
C       move down one line
          End If

          if (out(i) .ne. 32) then
C Write only non-blank entries
C
               ix = 11 * ip - 4
c        ix = 6 * ip - 5
        call dtcat(ix,iy)
C       position cursor
        write(*,231) out(i)
C       write * to screen
 231            format($,a1, $)
          end if
      end do
C # days in month

 999    call dtcat(1,23)
C Position for next prompt

      end
C -h- fnscan.for  Tue Jul  8 16:05:30 1986
c subroutine FNSCAN - scan file-name record (999999999x<filespec>=)
c and strip space, mark 0 at end of name

      subroutine fnscan(work, maxlen, iwkln, ijr)

      INTEGER*1 work(maxlen)

      INTEGER*1 ll

      ij = 0
C Initialize output index
      do (ii=1, min0(iwkln, maxlen))
C Start loop
          ll = work(ii)
C Get input character
          if (ll .gt. 32) then
C Strip all spaces & ctls
        if (ll .eq. ichar('=')) go to 10
C '=' marks end
        ij = ij + 1
C Character accepted
        work(ij) = ll
C Copy it
          end if
C (graphic character)
      end do
C Loop

 10     work(min0(ij+1,maxlen)) = 0
C Set marker for OPEN

      ijr = ij
C Return length of string

      end
C -h- week.for    Tue Jul  8 16:05:58 1986
c-----------------------------------------------------------------------
C       Week-at-a-glance subroutine
C       part of Mitch Wyle's DTC program
C       Input:
c               line    -       72 INTEGER*1 string;  Format: W [mmddyy]
C       Output:
c               display screen (see below)
C-----------------------------------------------------------------------
C       Modified 850117 to fix leap-year problems - CG
c       Modified 850314 to use real corners, lines and T's for box - CG
c       Modified 850318 to display current date in reverse video - CG
c       Modified 850806 to use new subroutines (including DTCRDAPPT)
c               and get rid of previously commented-out code
c
      SUBROUTINE week
C (line)
C       Declarations:
c
      include comdtc.INC
      include apptdtc.INC
      include escdtc.INC
c
      INTEGER*1 ln1, ll
C       equiv to input line
      INTEGER*1 temp(2)
C       temporary string converting array
      logical apts(7,19), aptsln(133), tflg
      Integer*4  prveof, eofflg
      Integer*4  HASH
      Integer*4    id
C       Julian Day
      Integer*4  im
C       Julian Month
      Integer*4  iy, iyd
C       Julian Year

c lengths of months ... leap years adjusted in code
c December Jan ... Dec Jan
      Integer*4  ml(14)
        include stmtfuncsp.for
      equivalence (line, ln1), (apts, aptsln)
       include comdtcd.inc
       include escdtcd.inc
      Data ml
     1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/

      include stmtfunc.for

c       Initialize:

      iss = z'7FFFFFFF'
C Impossible saved Sunday day...
      iwf=0
C Adjustment factor

      if ((ln1 .and. ucmask) .eq. Ichar('W'))
     1 call shrink(1, ifnb, lnb)

      call dtcidate(imx,idx,iyx)
C       initialize to today's date

      call dtcdatcvt(3)
C       Get date string

      im=idmo
C       Copy values
      id=iddy
      iy=ibigyr

      if (islpyr(iy)) then
        ml(3)=29
C Feb is in ML(3), not ML(2)
C
          else
        ml(3)=28
C C Garman, 17-Jan-1985
      end if

C Where we look for free space of n units or more length,
C then just display reverse and zot out all shorter periods

      if (ctlfg .eq. 1) rdspfg=1
      tflg = (rdspfg .ne. 0)
C initialize flag
      do (ij = 1, 7*19)
          aptsln(ij) = tflg
      end do

      if (ctlfg .ne. 0) then
C Locate N

          intsz = 0
          i = 1
          do while(numeric(line(i)))
        intsz = (intsz * 10) + icvtbn1(line(i))
        i = i + 1
        if (i .gt. icmln) go to 1191
          end do

c clamp interval size to permissible range...

 1191       intsz = min0(max0(intsz, 1), 18)

       end if
C               Paint the screen:
c

c following sequence moves to upper left corner on VT100 compatible terminals
c and clears screen

      write(*,6) esc,homescrn, esc,clrscrn
 6      format(1x,4a,$)
        call dtcat(1,1)
c Now write box, in graphics mode, to enclose days of week

      write (*, 70)  '+', '+'
C Upper corners & top line
c
      irow=2
      Do (i = 1, 6)
C 6 more days' worth
      Call DtcAt(1,irow)
      irow=irow+1
          write (*, 71)
      Call DtcAt(1,irow)
      irow=irow+1
          write (*, 71)
      Call DtcAt(1,irow)
      irow=irow+1
          write (*, 72) 
      end do
c
      Call DtcAt(1,irow)
      irow=irow+1
      write (*, 71) 
      Call DtcAt(1,irow)
      irow=irow+1
      write (*, 71) 
C two more sides
      Call DtcAt(1,irow)
      irow=irow+1
      write (*, 73)  '+', '+'
C Lower corners & bottom line
c
 70     format (x, 1a1, 74('-'), 1a1)
C Upper/lower corners
C sides
 71     format (x,  '|', 74(' '), '|')
 72     format (x,  '+', 74('-'), '+')
C interior lines
 73     format (x, 1a1, 74('-'), 1a1)
C Upper/lower corne1rs

      call dtcat(2,2)
      write(*,10) '   Sunday'
 10     format($,a)
      call dtcat(2,5)
      write(*,10) '   Monday'
      call dtcat(2,8)
      write(*,10) '  Tuesday'
      call dtcat(2,11)
      write(*,10) 'Wednesday'
      call dtcat(2,14)
      write(*,10) ' Thursday'
      call dtcat(2,17)
      write(*,10) '   Friday'
      call dtcat(2,20)
      write(*,10) ' Saturday'

C       Now figure out which Sunday is closest to the day specified by id:
c

      call dtcalcdow(ib,il,im,iy)
C Remember: ib = 1st day of month

c il = length of month
c ib = day number of 1st day of month, 1=sunday.

      if ( ib .eq. 1 ) then
          is = 1
C IS is the Sunday we want.  It is
      else
C either the 1st day of the month
          is = 9 - ib
C or 9 - 1st day of month.
      end if

C Now...Sunday may be in preceding month
 11     continue
C If the day is not in the 1st week
c try to fix up case of wrong sunday..
c ML array is preceding month's length
      iwf=0
      if (id .lt. is) then
        is=is-7+ml(im)
        im=im-1
        if (im .le. 0) then
c adjust year wrapback
                im=12
                iy=iy-1
        end if
        il=ml(im+1)
        iwf=-il
        go to 301
      end if
      if ( ( id - is ) .ge. 7 ) then
C of the month, then keep adding
          is = is + 7
C 7 until we get to the week we
          go to 11
C want.
      end if
 301    continue
c since we can wrap months down as well as up construct date limits here...
c ***   if (iy .gt. 1900) iy=iy-1900
c just generate a hashcode that is strictly increasing as a function of
c date. only purpose is to be monotonic increasing, so continuity is
c not important. we use other methods to handle exact offsets. note that
c where wrap arounds occur, iss is allowed to be a little larger than
c real month length or a small negative where used below...not here.

      irqhash(1) = ihymd(iy, im, is)
      iss = is
C don't lose track of Sunday's date.
      issss = is
C It will be important later...
C       Now figure out where to write the dates of the days of the week,
c       and write em out where they belong:
c
      iyd = mod(iy, 100)
C Display two digits

      Do (i=1,7)
          jy = 3 * i
          call dtcat(2,jy)
          if ((im .eq. imx) .and. (iy .eq. iyx)) then
        if (is .eq. idx) then
            if (id .eq. idx) then
C reverse + underline
                write(*,130,err=99)
     1              esc,'[4;7m', im,is,iyd, esc,resetvattr
            else
C reverse only
                write(*,130,err=99)
     1              esc,revattr, im,is,iyd, esc,resetvattr
            end if
        else
            go to 684
        end if
          else
 684            if (is .eq. id) then
C underline only
            write(*,130,err=99)
     1          esc,'[4m', im,is,iyd, esc,resetvattr
        else
C N/O/T/A, nothing fancy
            write(*,13,err=99) im,is,iyd
        end if
          end if

 99         is = is + 1
          If ( is .gt. il ) then
C Did the month change
        is = 1
C during this week?
        im = im + 1
        If ( im .gt. 12 ) then
C Did the year change
            im = 1
C during this week?
            iy = iy + 1
            iyd = mod(iy, 100)
        End If
          End If

      irqhash(2) = ihymd(iy, im, is)
C save last day value in hash

      end do

 13     format($, i3, '/', i2.2,'/',i2.2)
 130    format($, a1, a, i3, '/', i2.2,'/',i2.2, a1, a)

C               Now for Files I/O:
c

c       Set up a boolean array of appointment times and days of
c       the week.  Notice that if this program were written in
c       assembler, we would use only 18 INTEGER*1s and store this
c       information by bits instead of INTEGER*1s.  Oh well.  There
c       goes 100 INTEGER*1s of storage space...
c       When life confronts you with its troubles and woes,
c       Have no fear, just fire photon torpedos
C

C       Read the appointments; If the appointment is for one of
c       the days in this week, mark that spot in the appointments
c       array true.  Otherwise that coordinate is false.  The array
c       looks like this:
C               Su Mo Tu We Th Fr Sa
C       8:00     T  F  F  F  F  F  F
C Appointment on Su at 8:00
c       8:30     F  T  T  T  F  F  F
C Appointments on Mo, Tu, We at 8:30
c       9:00     F  F  F  F  F  F  F
C No appointments at 9:00 this week
c       9:30
C        .       .  .  .  .  .  .  .
c        .       .  .  .  .  .  .  .            etcetera
c        .       .  .  .  .  .  .  .
c
C sic itur ad astra
C       Etcetra.  Caveat emptor and three other latin words.
C
      prveof = 0
      eofflg = -1

      do while (prveof .ge. 0)

          call dtcrdappt(eofflg, 0)
C Look at appointments file

          if (eofflg .ge. 0)
     1     then

C NOW we are testing the date range validly. However, we must adjust
C the ISS range to be in the range from - (small #) to +
C (or some such) to take into account the fact that it MUST be
C continuous in order to be transformed into a cursor address.
C FORTUNATELY we saved the appropriate length of month adjustment
C above so can add it back in here.  IWF=0 most times.

        iss=issss+iwf
        jx = ihd - iss + 1
C need a little more logic to handle crossing months here
c where jx >7 we have to adjust by length of month once more...
        if (jx .gt. 7) jx=jx+iwf
c also have to handle cases where we crossed months, by adding in
c length of previous month.
        if (jx .le. 0) jx=jx+ml(im)
        jy = min0(max0(((iht+2)/5)-15, 1), 19)

        if ((jx .ge. 1) .and. (jx .le. 7) .and.
     1      (jy .ge. 1) .and. (jy .le. 19))
     2    then

            apts(jx,jy) = .not. tflg
C Derived a long time ago
C

       end if

          end if

          prveof = eofflg

      end do
C while
C               Now display the information we have extracted:
c
      if (ctlfg .ne. 0) then
c here go through and look for "intsz" sized intervals and
c set apts(i,j) to .false. if the interval is too small...
          k=19-intsz
          Do (i=1,7)
        Do (j=1,k)
            ivl=1
            Do (l=1,intsz)
                if (.not. apts(i,j+l-1)) ivl=0
            end do
            if (ivl .ne. 1) apts(i,j)= .false.
        end do
c since we are showing valid start times, set all times at the end of
c the day false since they can't possibly be valid times for any
c meetings.
        kk=k+1
        if (kk .le. 18) then
            do (j=kk,18)
                apts(i,j)= .false.
            end do
        end if
          end do
      End If

      Do (i=1,7)
C Go through the entire
          Do (j=1,19)
C array and display
        If ( apts(i,j) ) then
C appts if they exist:
            jx = 6 * j + 10
C jx is x coord of cursor
            jy = 3 * i - 1
C jy is y coord of cursor

            If ( jx .gt. 74) then
C For afternoon and evening
                jy = jy + 1
C appointments, put the
                jx = jx - 63
C appointments on the second
            End If
C line of the day

            jj = j
C Now decode the time again
            call dtcat(jx,jy)
C to display.  jj is time
            if (((j/2)*2) .ne. j) then
C of appointment
                jj = jj + 7 - (jj/2)
C If the time is odd then
                write(*,16) jj
C it falls on the hour.
 16                     format($,i2,':00')
            else
                jj = jj + 7 - (jj/2)
C If the time is even then
                write(*,17) jj
C it falls on the half hour
 17                     format($,i2,':30')
            end if
        End If
          end do
      end do

 999    call dtcat(1,22)
C move cursor to the bottom
      end
C of the screen and return
C -h- year.for    Tue Jul  8 16:06:21 1986
c-----------------------------------------------------------------------
C       Year-at-a-glance subroutine
C       part of Mitch Wyle's DTC program
C       Input:
c               line    -       72 INTEGER*1 string;  Format: Y [yy]
C       Output:
c               display screen (see below)
C-----------------------------------------------------------------------
c

      SUBROUTINE year
C (line)

c Declarations:

      include comdtc.INC
      include escdtc.INC

      INTEGER*1 temp(4), ln1
      Character*4 tempc
      Equivalence(tempc,temp(1))
      Character*2 tempc2
      Equivalence(tempc2,temp(1))
C       temporary string converting array

      Integer*4    id, idr
C       Julian Day
      Integer*4 im, imr
C       Julian Month
      Integer*4 iye, iyr
C       Julian Year
      Integer*4 iyo
C       y offset for where to put month data
      Integer*4   ix
C       x coord of cursor
      Integer*4 iy
C       y coord of cursor
      Integer*4   img
C       month loop index goes from 1 to 12
      Integer*4   jg
C       index offset defined by img
      Integer*4 ii
C       implied do loop index variable
      INTEGER*1 monthn(9)
C       string month name
      real badf77
      real badftn
C       Maybe error in array subscripts
c string containing names of days of week
      character*21 wknam
C       Hoolay kan
      INTEGER*1 ihold
C       hold the screen

c Entries true if length of name is even
      logical*1 lmneven(12)

      equivalence (line, ln1)
       include comdtcd.inc
       include escdtcd.inc
      Data wknam
     1 / 'Su Mo Tu We Th Fr Sa|'/
      Data lmneven/
     1 .false., .true., .false., .false., .false., .true.,
     2  .true., .true., .false., .false., .true.,  .true./


      if ((ln1 .and. ucmask) .eq. ichar('Y'))
     1 call shrink(1, ifnb, lnb)

      call dtcdatcvt(1)
C       Parse out a year value

      im=idmo
      id=iddy
      iye=ibigyr
c
      call dtcidate(imr,idr,iyr)
C       initialize to today's date

C       to display in reverse video

c set screen to 132 col, double width for 
	write(*,300) esc,'[0;0H',esc,'[1J'
C Erase screen first in this mode...
      write(*,300) esc,'[?3h',
     1 esc,'[2H', esc,'#6',
     2 esc,'[14H', esc,'#6'
C Month headers
      Write(tempc,20,err=97)iye
c      encode (4, 20, temp, err=97) iye
 20     format(i4)

 97     ix = 29
      iy = 11
      call dtcat(ix,iy)
C Display year in
      write(*,305) esc,dhdw1, temp
C double height/double width
c *******&&&& ??????
C in the middle of the screen
      iy = 12
      call dtcat(ix,iy)
      write(*,305) esc,dhdw2, temp
C second line

 99     Do 4 img = 1,12
C       for each month:
          call dtcmthnam(img,monthn)
C       Find out name, and display it
          jg = img - 1
C       x coord of cursor for month
          if (jg .gt. 5) jg = jg - 6
C       name in outstring
          ix = ( jg * 22 ) + 1
C
          if (img .gt. 6) then
C       First six months on top
        iy = 14
C       last six months on bottom
          else
C       half of screen
        iy = 2
          end if
c          ixx = (ix/2) + 2
c ***       if (lmneven(img)) ixx = ixx + 1
	call dtcat(ix,iy)
c          call dtcat(ixx,iy)
C       Position cursor and:
          write(*,3) monthn
 3          format($,21a1)
C       Write out the name.
 300        format($,40a)
 305        format($, 2a, 4(x, a))
 399        format($,a21)
C       Write out the name.
          If (img .gt. 6) then
C       Write out day of week
        iy = 15
C       Header names also, one
          else
C       line below month names
        iy = 3
          end if
          call dtcat(ix,iy)
          write(*,399) wknam

          If (img .gt. 6) then
C       Write out numbers for
        iy = 15
C       Days in each month:
        iyo = 12
          else
        iy = 4
        iyo = 0
          end if
          call dtcalcdow(ib,il,img,iye)
C       Now position the month
          ix = ix - 1
C       Off by 1.  CORRECT IT
          ixspa = 0
          ixo   = 0
          iyspa = 0
          call dtcdspmth(ib,il,ix,ixspa,iyo,iyspa)

c If displaying current year, mark today's date in reverse video

          if ((iye .eq. iyr) .and. (img .eq. imr)) then
        idw = mod(ib + idr -2, 7)
C Day of week and
        iwm = (idr + ib - 2)/7
C week of month (orig 0)
        if (img .gt. 6) iwm = iwm + 1
C Down one more line for Jul-Dec
        call dtcat((idw * 3) + ix + 1, iy + iwm)
        write (*, 301) esc,'[5;7m', idr, esc,resetvattr
 301            format ($, 2a, i2, 2a, $)
          end  if
 4      Continue

      call dtcat (1,23)
C Reposition cursor

c return next line read in and allow main pgm to decode...
      read(*,80,END=914)line
 80     format(84a1)
 914    Continue
	write(*,300) esc,'[?3l'
	Return
      end
C -h- strip.for   Tue Jul  8 16:06:45 1986
c-----------------------------------------------------------------------
C       Strip Daily Appointment subroutine (DTC Purge command)
C       part of GLENN EVERHART'S MODS TO DTC program
C       Input: command line - 72 INTEGER*1s, format:
C               P [mmddyy]
c                    or
c               U [mmddyy] [hh:mm[>hh:mm]]
c                    or
c               X [mmddyy] [hh:mm[>hh:mm]] [mmddyy] [hh:mm[>hh:mm]]
C       Output:
c               Reads dtc.dat, and builds new dtc.dat, in the process
c       strips old appointments (before date) from file (P),
c       deletes appointments at specified time and date (U),
c       or re-schedules (eXchanges) appointments from d1*t1 to d2*t2
c for Amiga, since we don't have version numbers, build DTC.TMP and
c copy onto DTC.DAT (or whatever) later...
C-----------------------------------------------------------------------
c

      SUBROUTINE strip
C (line)

C       Declarations:
c
      include comdtc.INC
      include apptdtc.INC
c
C       Function constants: Purge
C       .. Unschedule
      parameter (idspp = 1)
      Parameter (idspu = 2)
      Parameter (idspx = 3)
C       .. eXchange
C       INTEGER*1 line(1)
C       input line
C       temporary string converting array
      INTEGER*1 temp(2), ll,
     1 ln1, ap1
C       For RDAPPT 'do while' loop
      Integer*4 eofflg, prveof,
     1  firstflg
      Integer*4   id, idx
C       Julian Day
      Integer*4 im, imx
C       Julian Month
      Integer*4 iye, iyx
C       Julian Year
      Integer*4 it1, it2, itx1, itx2
C time values 80 (8 AM) => 173 (5:30 PM)
c
      logical first
C       For X decode
       Character*1 ln1c
       equivalence (line, ln1)
c      equivalence (appoin, ap1)
       Equivalence (ln1,ln1c)
       include stmtfuncsp.for
       include comdtcd.inc
c
      include stmtfunc.for
C Get standard statement functions

c Parse input line:
c       Was there a P on the front?  If so, trim it off:
c

	iopn2=0
c flag we opened DTC.TMP, 1 if true...
      isavinc = incmod
C Save for increment in DATCVT

      first = .true.
C Set it regardless of path

      If ( ln1c .eq. 'P' ) then

          idisp = idspp
C Function to perform

      else

          if (ln1c .eq. 'U') then
        idisp = idspu
          else if (ln1c .eq. 'X') then
        idisp = idspx
          else
        go to 999
C Error, can't decode it
          end if

          it1 = 80
C Set comparison values
          it2 = 180
          itx1 = it1
          itx2 = it2

      End If

      call shrink (1, ifnb, lnb)

      if (ifnb .eq. 0) then
          if (idisp .eq. idspp) then
        call dtcidate(im,id,iye)
C set to today's date
          else
        go to 999
C Not enough info for U or X
          end if
      else
C               If the date was specified in command line then
c               set id, im and iye to the right values:
c
 10         call dtcdatcvt(3)
C (line)

          if (first) then
C Note we decode into
        im = idmo
C second set of values,
        id = iddy
C then copy into first set
        iye = ibigyr
C first (or only) time around
          end if
C (unlike Schlitz, we can go around twice)

          if (idisp .ne. idspp) then
C other than purge
c ***           itx2 = 175
C Set default for '*' or <null>
        call dtctimcvt(itx1, itx2)
        if (itx1 .eq. itx2)
     1      itx2 = itx2 + 1
C Add (10 mins) to allow semi-open interval
        if (first) then
            it1 = itx1
            it2 = itx2
            if (idisp .eq. idspx) then
                if (ln1 .eq. 0) go to 999
C Error if nothing left
                first = .false.
                go to 10
C Re-cycle code
            end if
C Done unless X
        end if
          else
C P, guarantee no redisplay
        ln1 = 0
C Zap the line
          end if
C Done parse for U, X
      end if
C Done date/time parse

      ixhash = ihymd(iye, im, id)
C Calc hash for day of interest

c ***   type 950, ixhash
c *** 950       format(2z9.8)

      if (idisp .eq. idspp)
     1 then
C Set request date for RDAPPT
          irqhash(1) = ixhash
C Delete before
        else
          irqhash(1) = 0
C Look at everybody
      end if

      irqhash(2) = Z'7FFFFFFF'
C 'Til the end of time

      firstflg = 0
C Zero until file opened for write

      prveof = 0
      eofflg = -1

      do while (prveof .ge. 0)

          call dtcrdappt(eofflg, 1)
C Look at control entries

          if (eofflg .gt. 0)
     1     then
        eofflg = 0
C Don't open it on return
        go to 190
C but re-write it as is

C Test it now
          else if (eofflg .eq. 0)
     1     then

c ***   type 950, irchash

        iht = min0(max0(iht, 80), 173)
C Insure a kosher time value

        go to (110, 120, 130) idisp
C Dispatch on numeric value
        go to 190
C Bad call, re-write anyway?

 120            if ((irchash .eq. ixhash) .and.
     1      ((iht .ge. it1) .and. (iht .lt. it2)))
     2      go to 100
C Criteria for Unscheduling (deleting)
        go to 190
C Do re-write

 130            if ((irchash .eq. ixhash) .and.
     1      ((iht .ge. it1) .and. (iht .lt. it2)))
     2    then

            iht = itx1 + (iht - it1)
C Get updated time
            if (mod(iht, 10) .eq. 6) iht = iht + 4
C go to next hour

            if (iht .gt. itx2) go to 100
C Duration was shortened

            ihy = ibigyr
C Change dates
            ihm = idmo
            ihd = iddy

        end if
C Usually re-write
c
 110            continue
C Purge, re-write

C Can't open output till
 190            if (firstflg .eq. 0)
     1    then
C we have input
C

            close(3)
c            open(unit=3, file=FNc(1:fnsz), status='NEW',
c     1          form='FORMATTED',
c     1          err=999)
9991    continue
            open(unit=3, file='DTC.TMP', status='NEW',
     1          form='FORMATTED',
     1          err=999)
	  iopn2=1
c flag we got DTC.TMP open...
            firstflg = 1
C Output now open

        end if

        write (3, 201,err=9991) ihy, ihm, ihd, iht,
     1          apptstr(1:min0(max0(iaptln, 1), iaptlim))
c ***   1         (appoin(k), k=1, min0(max0(iaptln, 1), iaptlim))
 201            format(i4.4, 2i2.2, i3.3, x, a)
C New format, 19850806113

          end if
C eofflg

 100        prveof = eofflg
C Set loop condition

      end do
C while

C Purged everything?
      if (firstflg .eq. 0)
     1 then
C create empty file

          close(3)
c          open(unit=3, file=FNc(1:fnsz), status='NEW',
c     1  form='FORMATTED',
c     1  err=999)
          open(unit=3, file='DTC.TMP', status='NEW',
     1  form='FORMATTED',
     1  err=999)
          iopn2=1
          firstflg = 1
C Output now open

       end if

	if(iopn2.le.0)goto 9403
c Amiga ...
c rewind 1 and 2, then copy DTC.TMP into DTC.DAT (or wherever)
c	Rewind 1
        close(1)
        close(4)
        open(unit=4, file=FNc(1:fnsz), status='NEW',
     1  form='FORMATTED',err=999)
c re-open unit 4 if we can, for write...
c	Rewind 3
          close(3)
          open(unit=3, file='DTC.TMP', status='old',
     1  form='FORMATTED',
     1  err=999)

9402	continue
	Read (3,201,end=9401,err=9401) ihy,ihm,ihd,iht,apptstr
c read temp file, write back new appt file
        write (4, 201,err=9401) ihy, ihm, ihd, iht, apptstr
c 201            format(i4.4, 2i2.2, i3.3, x, a)
	goto 9402
9401	continue
	close(3,Status='delete')
        close(4)
        firstflg=0
        iopn2=0
9403	continue
        close(3)
        close(2)
        close(4)
        close(1)
C Done with new files

        return

 999    write (*, 990)
C Error on decode, write nastygram
 990    format($,'Syntax or file-open (write) error.', $)
       ln1 = 0
C Inhibit rescan
c
      end
C -h- dtcdatcvt.for       Tue Jul  8 16:07:21 1986
c Date conversion function (part of DTC), derived from DATMUN,
c except decodes the values directly into DEFDAT and shrinks LINE,
c rather than schlep LINE back and forth to kingdom come.
C Modified 850422, CG, to restrict values of month/day/year
C modified 850325, 850726 & 850731, CG, to allow any of the following:
c       d{d}/m{m}/{y}y, d, dd, dmm, ddmm, dmmyy, ddmmyy, dmmyyyy, ddmmyyyy
c                                                       for D or W functions
c       m{m}/{y}y, m, mm, myy, mmyy, mmyyyy, myyyy      for M
c       y, yy, yyy, yyyy                                for Y
C plus dd-mon-yy, dd-mm-yy, dd-xii-yy formats
C function:
c  Convert a line starting with a date of form
c       mmddyy OR mm/dd/yy OR dd-mon-yy OR dd-romn-yy
c  to binary equivalents, and remove from line, copying binary values
c  to DEFDAT in common.
C  Leaves whatever follows the date alone.
c  Added for DTC to not have to use such a crock date
c  format as the original; too hard to use otherwise.

      Subroutine dtcdatcvt (nf)
C (line,nf)
c
c      implicit none
c
      Integer*4  nf
C Number of fields expected
c
      include comdtc.INC
c
      INTEGER*1 nb, l1, l2, l3, l4, lxx(4), work(icmln), tb6(6)
C,
c
C lengths of months (30 days hath Sept ...)
      Integer*4 lm(12)
c
C Min chars to recognize month names
      Integer*4 minln(12)

C Decode month names, or European style w/ Roman months
      character*4 rch,mab(12),rom(12)

      Integer*4 i, k, kkk, n, nn, ix, ixyr, ixmo, ixdy, nfd,
     1  ifnb, lnb, lcount

      logical longyr
C If year entered as 3 chars or more

      integer*2 iwk(42), lw1
      integer*1 iwkk(84),ln1
      Character*1 ln1c
      Equivalence (work,iwkk)
C 2 chars at a time
c
      Integer*4  ll1

      equivalence(line(1),ln1)
      equivalence (ln1,lw1),(ll1,rch)
      equivalence (rch, lxx), (work, iwk)
      equivalence(line(1),ln1c)
c
      Integer*4 icvt10, icur
      INTEGER*1 ich
      include stmtfuncsp.for
      include comdtcd.inc

      Data lm
     1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
c
C Min chars to recognize month names
       Data minln
     1 /2, 1, 3, 2, 3, 3, 3, 2, 1, 1, 1, 1/

C Decode month names, or European style w/ Roman months
      Data
     1 mab / 'JANU', 'FEBR', 'MARC', 'APRI', 'MAY ', 'JUNE',
     2      'JULY', 'AUGU', 'SEPT', 'OCTO', 'NOVE', 'DECE'/,
     3 rom / 'I   ', 'II  ', 'III ', 'IV  ', 'V   ', 'VI  ',
     4      'VII ', 'VIII', 'IX  ', 'X   ', 'XI  ', 'XII '/

       include stmtfunc.for
      icvt10(icur, ich) = (icur * 10) + icvtbn1(ich)
C conversion function stage

c Begin code

      longyr = .false.
C set default of century calculation

c Initialize default values for omitted fields

      ixyr = ibigyr
C Copy current values
      ixmo = idmo
C from common
      ixdy = iddy
      if (numeric(ln1)) then
C Dates must start with number

          work(1) = ln1
C Copy first character
          ix = icvtbn1(ln1)
C Compute value on the fly
c
          do (n = 2, (nf * 2) + 2)
C Allow [mm][dd][yyyy]
c
        l1 = line(n)
C Copy current character

C Field separators: slash
        if (l1 .eq. ichar('/'))
     1      go to 100
C for mm/dd/yy form

C .. dash
        if (l1 .eq. ichar('-'))
     1      go to 200
C for dd-mmm-yy form

        if ((l1 .eq. ichar(':')) .or. (l1 .eq.ichar('>')))
     1      go to 999
C hour-string first, return default values
C anything else:
        if (.not. numeric(l1))
     1      go to 300	
C mmddyy, minus some characters, fake whatever is required

        work(n) = l1
C Don't recopy
        ix = icvt10(ix, l1)
C continue conversion

          end do

          n = (nf * 2) + 3
C Set shrink value if no delimiter

          go to 300
C Go convert it

      else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) then
          k = incmod
C Save current value
          call dtcdatinc
C Convert incremental date
          incmod = k
C Restore
      else if (ln1c .eq. '=') then
          kkk = 1
C Place holder, strip only, date n/c
          go to 950
      end if
C (don't want to reformat whole file)

      go to 999
C All done here

c handle mm/dd or mm/dd/yy{yy} (for D, W, M or Y)
c or mm/yy{yy} (for M or Y)

 100    continue
C Here for '/' encountered in first scan loop

      k = n + 1
C next character to look at
      l1 = line(k)
      if (.not. numeric(l1)) go to 300
C nnnn/x ???

      ixmo = ix
C First field is always month in "/" notation

      ix = icvtbn1(l1)
C Start 2nd conversion

      do (n = k + 1, 20)
C should be plenty

          l1 = line(n)
C get character
          if (l1 .eq. ichar('/')) go to 110
C Found second /
          if (.not. numeric(l1)) go to 120
C End of scan
          ix = icvt10(ix, l1)
C convert

      end do

      n = 21
C Set it

 120    if (nf .eq. 3) then
          ixdy = ix
C 2nd field is day
      else
          ixyr = ix
C .. year
          longyr = ((n - k) .gt. 2)
      end if

      go to 900

 110    l1 = line(n+1)
C Found 2nd slash, check for third field
      if (.not. numeric(l1)) go to 120
C left field
C

      k = n + 1

      ixdy = ix
C 2nd has to be day

      ixyr = icvtbn1(l1)
C Start 3rd conversion (year)

      do (n = k + 1, 20)
C get more numerics

          l1 = line(n)
          if (.not. numeric(l1)) go to 910
          ixyr = icvt10(ixyr, l1)

      end do

      n = 21
C mark next character

      go to 910
C set for SHRINK

c handle dd-mon-yy, dd-mm-yy, or dd-roman-yy

 200    continue
C Here for '-' in first scan loop

      ixdy = ix
C Copy converted day field

      rch = '    '
C initialize for alpha month name, or Roman numerals

      k = n + 1
C next char after "-"

      l1 = line(k)

      if (numeric(l1)) then
C European format dd-mm-yy

          ixmo = icvtbn1(l1)
C go for it directly

          do (n = k + 1, 20)

        l1 = line(n)

        if (.not. numeric(l1)) go to 210

        ixmo = icvt10(ixmo, l1)

          end do

          n = 21

      else if (alpha(l1)) then

          lxx(1) = l1 .and. z'5F5f5f5f'
C Set first char for name or roman

          lcount = 1

          do (nn = k + 1, k + 6)
C should find "-" by then

        l1 = line(nn)
        if (l1 .eq. ichar('-')) go to 230
C Start search
        if (.not. alpha(l1)) go to 230
C also terminate
        if (lcount .lt. 4) then
C room for at least one more
            lcount = lcount + 1
            lxx(lcount) = l1 .and. z'5F5f5f5f'
C Copy character
        end if
          end do

          nn = k + 6

 230        continue

          do (i = 1, 12)
C Loop over months
        if (rch .eq. rom(i)) go to 250
C Found match in roman set
        if (lcount .ge. minln(i)) then
            if (rch(1:lcount) .eq. mab(i)(1:lcount))
     1          go to 250
C Found match in alpha names
        end if

C Note: last two IF statements above replace original horrendous sequence of
c IF-THEN-ELSEs to see if month was J then A, or F, or M then A then R, etc
C
         end do

c Fell out of loop, leave current month

          go to 300
C Unknown month or roman seq, back up before "-"

 250        ixmo = i
C iwk(1) = icvtbcd(i)
          n = nn
C Accept characters

      else
C "-" followed by non alphanumeric
          go to 300
      end if

 210    if (l1 .ne. ichar('-')) go to 900
C See if year follows

      k = n + 1
      l1 = line (k)

      if (.not. numeric(l1)) go to 910
C First dash is left
      ixyr = icvtbn1(l1)

      do (n = k + 1, 30)

          l1 = line (n)

          if (.not. numeric(l1)) go to 910

          ixyr = icvt10(ixyr, l1)

      end do

      n = 31

 910    longyr = ((n - k) .gt. 2)
C Set logic value

      go to 900

300      continue
C Short string found, fix it up

      nfd = n/2
C Number of 2-char groups found

      longyr = (nfd .gt. nf)
C check for default or forced century

      if ((n .and. 1) .eq. 0) then
C Example: n = 5 for 4 chars found (0 mod 2)
          work(1) = '0'
C Force even number of characters
          do (i = 2, n)
        work(i) = line(i - 1)
C Shift line over by 1
          end do
      end if

      go to (310, 320, 330) nf
C Dispatch on # expected fields
      go to 900
C Bad value ???

 310    ixyr = ix
C take year: Y [yy]
      go to 900
C End case

 320    ixmo = icvtbin(iwkk(1))
C M mm
      if (nfd .eq. 2) ixyr = icvtbin(iwkk(3))
C M {m}myy
      if (nfd .eq. 3) ixyr = mod(ix, 10000)
C M {m}myyyy
      go to 900
C End case

 330    if (nfd .eq. 1) ixdy = icvtbin(iwkk(1))
C D {d}d {only}

      if (nfd .ge. 2) then
C D [mm]dd[yy]
          ixmo = icvtbin(iwkk(1))
C D {m}mdd
          ixdy = icvtbin(iwkk(3))
C D {m}mdd
      end if

      if (nfd .eq. 3) ixyr = icvtbin(iwkk(5))
C D {m}mddyy
      if (nfd .eq. 4) ixyr = mod(ix, 10000)
C D {m}mddyyyy

 900    continue
C common clean-up & return

C Check for 1-99 AD
      if ((ixyr .lt. 100) .and. (.not. longyr))
     1   ixyr = ixyr + ((ibigyr/100)*100)
C add "current" century

      if (islpyr(ixyr))
     1 then
          lm(2) = 29
C Set for Leap Years
        else
          lm(2) = 28
C reset for "common" years
      end if

      ibigyr = ixyr
C Explicit year
      idmo = min0(max0(ixmo, 1), 12)
C Limit values
      iddy = min0(max0(ixdy, 1), lm(idmo))
C ..

      kkk = n - 1
C Change index of next char to count

 950    idyr = mod(ibigyr, 100)
C Set value

      if (kkk .gt. 0)
     1 call shrink (kkk, ifnb, lnb)
C Unload the stuff we used

 999    return
C Miscellaneous exits
       end
c -h- dtctimcvt.for       Tue Jul  8 16:08:13 1986
c Subroutine to extract and convert time-of-day string for DTC package
c Converts string of form hh:mm to Integer*4 between 80 and 173
c (half-hour intervals).  If range h1:m1>h2:m2 is present, second
c value is returned, else same as t1>t1.

c Special cases
c       *       =>      {itr1}>{itr2}
c       E or EV =>      17:00
c       h:      =>      0h:00
c       h:n     =>      0h:n0   (if n .ge. 3, then 3, else 0)
c       h1>h2   =>      h1:00>h2:00

c If ':' or '>' is not 2nd or 3rd character, or not '*', 'E' or 'EV',
c entire string is left untouched, and default values are returned
c (parameters unchanged)

      subroutine dtctimcvt (itr1, itr2)

      include comdtc.INC

      INTEGER*1 ll, ln1, wk(2)
      integer*2 iwk
      character*2 icwk
      equivalence(icwk,iwk)
      integer*1 iwkk
      logical first, expectmin

      equivalence (line(1), ln1), (iwk, wk)
      equivalence(iwkk,wk(1))
      include stmtfuncsp.for
      include comdtcd.inc
      include stmtfunc.for

      it1 = itr1
C Caller's limits
      it2 = itr2
C (formerly 8:00 AM > 5:30 PM)

      ix = 0
C Amount to strip
      if(ln1.gt.96)ln1=ln1-32
      if (ln1 .eq. ichar('*')) then
C Check special cases first

          ix = 1
C Defaults, dump 1 char

      else if ((ln1 ) .eq. ichar('E')) then

          it1 = 170
C Set eventide
          it2 = it1

          ix = 1
          if(line(2).gt.96)line(2)=line(2)-32
          if ((line(2)) .eq. ichar('V')) ix = 2

      else

          i = 0
C Temp index
          first = .true.
C Helpful

 10         if (numeric(line(i+1))) then

        if (numeric(line(i+2))) then
            wk(1) = line(i+1)
            wk(2) = line(i+2)
            read(icwk,850)ih
850     format(BZ ,I2)
            ih=ih*10
c            ih = icvtbin(iwkk) * 10
            i = i + 2
        else
            ih = icvtbn1(line(i+1)) * 10
            i = i + 1
        end if

        if (line(i+1) .eq. ichar(':')) then
            i = i + 1
            if (numeric(line(i+1))) then
                im = icvtbn1(line(i+1))
                if (im .ge. 3) then
                    im = 3
                else
                    im = 0
                end if
                ih = ih + im
                i = i + 1
                if (numeric(line(i+1))) i = i + 1
C Just ignore it
            end if
            ix = i
C Accept all processed chars
        end if

        if ((ih .ge. 10) .and. (ih .lt. 70))
     1     ih = ih + 120
C Force early AM to PM
        ih = min0(max0(ih, 80), 180)
C Normalize within limits

        if (line(i+1) .eq. ichar('>')) then
            i = i + 1
            ix = i
C Insure it gets copied
            it2 = ih
            if (first) then
                it1 = it2
                first = .false.
                go to 10
            end if
        else if (ix .ne. 0)     then
C Got some numeric
            if (first) then
                it1 = ih
C terminated by ':'
                it2 = ih
C first time t1>t1
            else
                it2 = ih
C 2nd numeric
                ix = i
C Claim everything looked at
            end if
C Which time
        end if
C Range delimiter ('>')
          end if
C First numeric
      end if
C All others unrecognized (includes EOL)

      itr1 = it1
C All exit here
      itr2 = max0(it2, it1)
C Make sure range OK

      if (ix .ne. 0) call shrink (ix, ifnb, lnb)
C Unload what we've used

      end
C -h- shrink.for  Tue Jul  8 16:08:41 1986
c Subroutine to shift LINE to left after current item has been scanned
c deletes blanks between that point and first non-blank character
c Performs no operation if current item is EOL (binary 0)

c Sets return arguments pointing to first and last non-blank characters

      subroutine shrink (iskip, ifnbr, lnbr)
c
      include comdtc.INC

      INTEGER*1 ll
      include comdtcd.inc

      ifnb = 0
      lnb = 0

      if (line(1) .eq. 0) go to 999
C Exit immediately

      ix = iskip + 1
C start looking
      do while ((ix .le. icmln) .and. (line(ix) .ne. 0))
      if (line(ix) .gt. 32) go to 10
C Found something
      ix = ix + 1
      end do
      line(1) = 0
C Flag end, no copy
      go to 999

 10     ifnb = 1
      lnb = 1

      Do (i = 1, icmln-ix)

          ll = line(ix)
          line(i) = ll
          if (ll .eq. 0) go to 999
C Stop at EOL
          if (ll .gt. 32) lnb = i
          ix = ix + 1
      end do
      line(min0(lnb+1, icmln)) = 0
C Flag EOL if not found

 999    ifnbr = ifnb
C Set return values
      lnbr = lnb

      end
C -h- dtcat.for   Tue Jul  8 16:09:05 1986
      subroutine dtcat(ic,ir)
C x, y
c
      include comdtc.INC
C Need ITERM
      include escdtc.INC
C
      include comdtcd.inc
      include escdtcd.inc
      write(*,773)
773   format(' ')
c write once to flush extra junk out... then position.
      write(*, 2, err=3) esc,'[',ir,';',ic,'H'
 2      format($,2a1,i2.2,a1,i3.3,a1,$)
C Max rows is 2-digit number
c
      return
c
 3      write (*,10) esc,homescrn, ir, ic
 10     format($, 2a, 'Error in DTCAT, row/col =', 2z5.4, ' (hex).')
      end
C -h- gaby.for    Tue Jul  8 16:10:23 1986
c-----------------------------------------------------------------------
C       Subroutine Gaby
C       Part of Mitch Wyle's DTC program
C       return a string corresponding to the month number
c       Month number contained in im.  Send back string in monthn.
c       (JANUARY for 1, etc.)
C-----------------------------------------------------------------------
C       modified 850315 - Center month names in table, use mixed case - CG

      SUBROUTINE gaby(im,monthn)

C       Declarations:
c
      INTEGER*1 monthn(9)
C       Table of month names and numbers (centered, even lengths biased left):
c

      INTEGER*1 months(9,14)
      character*9 monthch(14)

      equivalence (months, monthch)
C       Select the right month and fill monthn with it:
c
      Data monthch/           'December ',
     1 ' January ', 'February ', '  March  ', '  April  ',
     2 '   May   ', '  June   ', '  July   ', ' August  ',
     3 'September', ' October ', 'November ', 'December ',
     4 ' January '/


C ALLOW FOR OVERFLOWS...
      IMM=IM+1
c ***   monthn = monthch(imm)
C String assignment
c
      Do 1 i=1,9
C INTEGER*1-at-a-time
          Monthn(i) = months(i,imm)
 1      Continue

c       All done.

      return
      end
c -h- ICVT routines
       Integer*2 function Icvtbin(ich2)
       Character*2 ich2
       Character*2 wrk
       integer*2 iwrk,ians
       Equivalence(wrk,iwrk)
c convert 2 digit Integer*4 to number
c avoid trick version from VAX that depends on byte
c ordering (which fails on MC68000).
       wrk=ich2
       Read(wrk,1,err=2)ians
1      Format(BN,I2)
2      Continue
       Icvtbin=ians
       Return
       End
       Function Icvtbn1(nnn)
       Integer*1 nnn
       Integer*4  kkk
       kkk=48
       if(nnn.ge.48.and.nnn.le.57)kkk=nnn
       kkk=kkk-48
c return 0 or digit value...
       Icvtbn1=kkk
       Return
       End
d       subroutine dely
d       Integer*4 idly,i1
d       common/xxxyyy/idly
d       idly=0
d       do 1 i1=1,15000
d       idly=idly+i1
d1      continue
d       idly=idly/100
d       return
d       end


