#-h- day.for         8386  asc  25-apr-85 11:53:40  garman
c-----------------------------------------------------------------------
c
c	Daily Appointment subroutine
c
c	part of Mitch Wyle's DTC program
c
c	Input: 
c       line - 72 bytes;  Format: D [mmddyy [hh:mm>HH:MM [appointment]]]
c
c	Output:
c		display screen (see below)
c
c-----------------------------------------------------------------------
C
c	Modified 850314 to write day-of-week to daily-appointment screen,
c	   and note current time if current day displayed (reverse video)
c		CG
c
	SUBROUTINE day		! (line)
c
c	Declarations:
c
	include 'comdtc.inc/nolist'
	include 'escdtc.inc/nolist'
c
c	byte line(1)		!	input line
	byte appoin(icmln)	!	appointment string
	byte work(icmln)	! 	scratch array for handling scheduling
	byte temp(2), ll, ln1,	!	temporary string converting array
	1 ap1
c	byte esc/"033/		!	escape character
	byte blot/26/		!	^Z, for entry from display
c	integer iterm/6/	! 	Terminal unit #
	integer	id, idr		!	Julian Day
	integer im, imr		!	Julian Month
	integer iye, iyr	!	Julian Year
	integer idx, imx, iyx, isx	! copies for calling DANY
c
	real*8 daylist(7) / '   Sun', '   Mon', '  Tues', ! uses A6 fmt
	1 'Wednes', ' Thurs', '   Fri', ' Satur' /	! 'day' is in format
c
	equivalence (line, ln1), (appoin, ap1)

	include 'stmtfunc.for/nolist'

c	Initialize:
c
c	iterm = 6		!	Output terminal unit number
c	esc = "033		!	Escape character

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

	call dtcdatcvt(3)		! Pick off a date value
c
	im=idmo
	id=iddy
	iye=idyr

	iyx = iye				! Can be modified
c
	call dany (isx, imx, im, iyx)		! Get day-of-week
c
	idx = mod (id + isx - 2, 7) + 1		! Calc current d/o/w
c
	call idate(imr, idr, iyr)		! Get today's date
c
	if ((im .eq. imr) .and.		! if current = today,
	1   (id .eq. idr) .and.		! flag current time
	2   (iye .eq. iyr)) then	! Displaying current day
c
	    scnds = amax1(secnds(0.), 28801.)	! Get current time (>8 AM)
	    ihalf = mod(ifix(scnds/1800.), 48) ! current half-hour (orig 0)
	    ihour = ihalf/2		!	Current hour
	    ihalf = ihalf - (ihour*2)	!	0 or 1 for half-hour
c
	else
	    ihour = 0			!	Set non-match value
	endif
c
c ************************** Move the cursor to top of screen and clear it,
c ************************** set up appointments display:
c
	write(iterm,4) esc,homescrn, esc,clrscrn
 4	format('+', 4a, $)

	write(iterm,5) '+', esc,dhdw1, daylist(idx),im,id,iye
 5	format(3a,'   Appointments for ', a6,'day, ',
	1 i2,'/',i2.2,'/',i2.2)
	write(iterm,5) ' ', esc,dhdw2, daylist(idx),im,id,iye

	Do i=8,16
	    If ( i .gt. 12 ) then
		j = i - 12
	    Else
		j = i
	    End If
c
	    if (i .ne. ihour) then			! Check for highlighting
		write(iterm,6) j
 6		format(x,i2,':00   -')
		write(iterm,7) j
 7		format(x,i2,':30   -')
	    else					! must be current hour
		if (ihalf .eq. 0) then		! Check which half
		    write(iterm,96), esc,revattr, j, esc,resetvattr
		    write(iterm,7) j
		else
		    write(iterm,6) j
		    write(iterm,97), esc,revattr, j, esc,resetvattr
		endif
c
 96	    format (x, 2a, i2,':00   -', 2a)
 97	    format (x, 2a, i2,':30   -', 2a)
c
	    endif
	end do

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

 9	format(x, 'Evening:', /, x, 78('='))
 98	format(x, 2a, 'Evening: ', 2a, /, x, 78('='))

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

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

	    call dtctimcvt(iht, ihmx)	! & a time value
	
	    ihh1 = (iht+2)/5		! Adds 1 if trailing 3
	    ihh2 = (ihmx+2)/5		! Result is 16 to 35
	    idmx = max0(ihh2-ihh1, 1)	! 8:00>5:30

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				! Clear appointment string

	    do i = 1, icmln
c
		ll = line(i)
		appoin(i) = ll
c
		if (ll .eq. 0) go to 6789		! done

		ivx = i					! Save current length

	    end do
c
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.
c		and when the band you're in starts playing different tunes,
c		I'll see you on the dark side of the moon.
c
 6789	    If (ap1 .eq. 0) then		! Empty appointment string
c
		iy = ihh1 - 13			! Vertical position for half hour
		ix = 11
		call dtcat(ix,iy)

		write(iterm, 987) blot, esc,'[D'	! write, backspace
 987		format ('+', 3a, $)
c
c !!!		close(iterm)
c
		read(5,13,END=914) lapp, work
 13		format(q,100a1)
c
c copy appointment for use later...
c
		ifnb = 0
		lnb = 0
		ivx = 0

		Do i = 1, lapp
c
		    ll = work(i)			! fetch character
c
		    if (ll .gt. ' ') then
			if (ifnb .eq. 0) ifnb = i	! Flag first non-blank
			lnb = i				! Flag last non-blank

		    end if

		    if (ifnb .ne. 0) then		! Copy after first n/b
			ivx = ivx + 1
			appoin(ivx) = ll
		    end if
c
		end do

		if (ifnb .eq. 0) go to 914		! Nothing on read either
c
	    End If
c
	    ivx = min0(ivx, iaptlim)	! ivx = length of string

	    iwy=iye
	    iwm=im
	    iwd=id
	    iwht=iht
c
	    close(1)			! add close to guarantee no failures...

c
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

		Open ( unit=1,file=FNAME,status='UNKNOWN',form='FORMATTED',
	1	carriagecontrol='LIST', access='APPEND',err=9876)

		ihtxx=iht
		do 3005 ixx = 1, idmx
		write(1,14) iye,im,id,ihtxx,(appoin(i),i=1, ivx)
		if ((ihtxx/10)*10 .eq. ihtxx) then
c
		    ihtxx=ihtxx+3	! IHT is even hour, go to next half hour
c
		else
c
		    ihtxx=ihtxx+7	! IHT is a half hour ... make up to next hour
c
		end if
 3005		continue
c
 14		format(3i2.2,i3.3,x,100a1)
		close(1)
c
	    End If

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

	end if
c
 9876	nunit=1
	Open (unit=nunit, file=FNAME, status='OLD', form='FORMATTED',
	1    readonly, err=99)

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


	read(nunit,200,end=400) ihy, ihm, ihd, iht, iwkln, work
 200	format(3i2, i3, q, 100a1)
c
	if ((ihm .eq. 99) .and. (nunit .eq. 1)) then

	    call fnscan(work, icmln, iwkln, ij)	! Common code to check filename

	    if (ij .ne. 0) then			! Skip if no file

		if (ctlfg .ne. 0) then

c on scheduling multiple dates via the S function, use this occasion to
c add the record to everyone's calendar file.
c
		    close(2)
		    Open (unit=2, file=work, status='OLD',
	1		form='FORMATTED', carriagecontrol='LIST',
	2		access='APPEND', err=1119)

		    ihtxx=iwht
		    do ixx = 1, idmx
			write(2,14) iwy,iwm,iwd,ihtxx,(appoin(i),i=1,ivx)
			if ((ihtxx/10)*10 .eq. ihtxx) then
			    ihtxx=ihtxx+3	! iht is an even hour ... add the half hour
			else
			    ihtxx=ihtxx+7	! iht is a half hour ... make up to next hour
			end if

		    end do

		    close(2)

		end if

 1119		nunit=2

		Open(unit=nunit,file=work,status='old',form='formatted',
	1	    readonly, carriagecontrol='LIST', err=1067)

	    end if		! non-null file-name

c Display appointment if it matches current date

	else If ((iye .eq. ihy) .and. (im .eq. ihm)
	1	 .and. (id .eq. ihd)) then

	    iy = min0(max0((((iht+2) / 5) - 13), 3), 22) ! Compute vertical posn
c
	    do kk = iaptlim + 1, 1, -1		! Trim trailing blanks and nulls
		if (work(kk) .gt. ' ') go to 1066	! and all that
	    end do

	    kk = 1			! Line was empty
	    work(1) = blot

 1066	    ix = 10
	    if (work(1) .ne. ' ') then
		ix = 11			! '12:00 - Appointment'
		kk = min0(kk, iaptlim)
	    end if
	    call dtcat(ix,iy)
	    write(iterm,300) (work(k),k=1,kk), esc,'[K'	! Erase EOL
 300	    format('+', <kk>a1, 2a, $)
	End If

	go to 100		! Read next line from current file

 400	continue	! no more appointments left in file.
	if (nunit .ne. 1) then
c
 1067	    continue
	    close(2)
	    nunit=1
	    go to 100
c
	end if
c
	go to 101			! Common exit code
c
 99	continue			! Error opening, create empty
	open(unit=1, file=FNAME, status='NEW', form='FORMATTED',
	1    carriagecontrol='LIST', err=101)
c
 101	close(1)
	call dtcat(1,22)
	return
	end
#-h- week.for       12828  asc  25-apr-85 11:53:43  garman
c-----------------------------------------------------------------------
c
c	Week-at-a-glance subroutine
c
c	part of Mitch Wyle's DTC program
c
c	Input: 
c		line 	- 	72 byte string;  Format: W [mmddyy]
c
c	Output:
c		display screen (see below)
c
c-----------------------------------------------------------------------
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
	SUBROUTINE week		! (line)
c
c	Declarations:
c
	include 'comdtc.inc/nolist'
	include 'escdtc.inc/nolist'
c
	byte ln1, ll		!	equiv to input line
	byte temp(2)		!	temporary string converting array
c	byte esc /27/,		!	escape character
c	1    so /14/,		!	shift out (^N) (enter graphics mode)
c	2    si /15/		!	shift in (^O) (exit graphics mode)
	byte appoin(iaptlim)	!	appointment array
	logical apts(7,19), aptsln(133), tflg
	INTEGER HASH
	integer	id		!	Julian Day
	integer im		!	Julian Month
	integer iy		!	Julian Year

c lengths of months ... kluge ... forget leap years...
	integer ml(14)		! December Jan ... Dec January
	1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/

	equivalence (line, ln1), (apts, aptsln)

	include 'stmtfunc.for/nolist'
c
c	integer iterm/6/
c
c	Initialize:
c
	iss=999                 !       impossible saved Sunday day...
c	iterm = 6		!	Output terminal unit number
c	esc = "033		!	Escape character

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

	call dtcdatcvt(3)	!	Get date string

	iwf=0

	im=idmo			! 	Copy values
	id=iddy
	iy=idyr

	if (mod(iy,4) .eq. 0) then
		ml(3)=29			! Feb is in ML(3), not ML(2)!!!
	    else
		ml(3)=28			! C Garman, 17-Jan-1985
	end if

C	call idate(im,id,iy)	!	initialize to today's date
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)	! initialize flag
	do ij = 1, 7*19
	    aptsln(ij) = tflg
	end do

c ***	Do 1111 i=1,7		!	clear any apointments from
c ***	   Do 1110 j=1,19	!	other weeks.
c ***		if (rdspfg. eq. 0) then
c ***		   apts(i,j) = .false.
c ***		else
c ***		   apts(i,j)= .true.
c ***		end if
c *** 1110	   Continue
c *** 1111	Continue

c
c		Trim off the W from command line:
c

c ***	    iender=1
c ***	    do 63 i=2,10
c ***	    if (line(i) .ne. ' ' .and. line(i) .ne. '	') go to 64
c ***	    iender=iender+1
c *** 63	    continue
c *** 64	    Do 1 i=1,70
c ***		line(i) = line(i+iender)
c *** 1	    Continue
c ***	call datmun (3)		! (line)
c
c		If the date was specified in command line then
c		set id, im and iy to the right values:
c

c ***	lft=1
c ***	If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
c ***	    lft=8
c ***	    temp(1) = line(1)
c ***	    temp(2) = line(2)
c ***	    decode ( 2 , 2 , temp ) im
c ***	    temp(1) = line(3)
c ***	    temp(2) = line(4)
c ***	    decode ( 2 , 2 , temp ) id
c ***	    temp(1) = line(5)
c ***	    temp(2) = line(6)
c ***	    decode ( 2 , 2 , temp ) iy
c ***	    decode (6, 92, line, err= 93) im, id, iy
c *** 93	    idmo=im
c ***	    iddy=id
c ***	    idyr=iy
c ***	End If
c
c ***
c *** 2	Format(i2)
c *** 92	format(3i2)
c *** 931	format(i1)
c

	if (ctlfg .ne. 0) then

c ***	  if (line(lft) .lt. '0') line(lft)='0'
c ***	  if (line(lft+1) .lt. '0' .or. line(lft+1) .gt. '9') then
c ***          decode(1,931,line(lft),err=1113)intsz
c ***	  else
c ***	  decode(2,2,line(lft),err=1113)intsz
c ***	  end if
c *** 1113	  continue
c ***	  if (intsz .le. 0)intsz=1
c ***	  if (intsz .gt. 18)intsz=18

	    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
c		Paint the screen:
c

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

	write(iterm,6) esc,homescrn, esc,clrscrn
 6	format('+',4a,$)

c Now write box, in graphics mode, to enclose days of week

	write (iterm, 70), so, 'l', 'k', si	! Upper corners & top line
c
	Do i = 1, 6				! 6 more days' worth
c ***	    write(iterm,7)
c *** 7	    format(x,79('-'),2(/,x,'|',t80,'|'))
	    write (iterm, 71), so, esc, esc, si
	    write (iterm, 72), so, si
	end do
c
	write (iterm, 71), so, esc, esc, si	! two more sides
	write (iterm, 73), so, 'm', 'j', si	! Lower corners & bottom line
c
 70	format ('+', 2a1, 77('q'), 2a1)		! Upper/lower corners
 71	format (x, a1, 'x', a1, '[77Cx'/
	1       x,     'x', a1, '[77Cx', a1)	! sides
 72	format (x, a1, 't', 77('q'), 'u', a1)	! interior lines
 73	format (x, 2a1, 77('q'), 2a1)		! Upper/lower corners
c
c ***	write(iterm,9)
c *** 9	format(x,79('-'))
	call dtcat(2,2)
	write(iterm,10) '   Sunday'
 10	format('+',a)
	call dtcat(2,5)
	write(iterm,10) '   Monday'
	call dtcat(2,8)
	write(iterm,10) '  Tuesday'
	call dtcat(2,11)
	write(iterm,10) 'Wednesday'
	call dtcat(2,14)
	write(iterm,10) ' Thursday'
	call dtcat(2,17)
	write(iterm,10) '   Friday'
	call dtcat(2,20)
	write(iterm,10) ' Saturday'

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

	call dany(ib,il,im,iy)		! 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			! IS is the Sunday we want.  It is
	else				! either the 1st day of the month
	    is = 9 - ib			! or 9 - 1st day of month.
C No...Sunday may be in preceding month
	end if

 11	continue			! If the day is not in the 1st week
c try to fix up case of wrong sunday..
c ML array is preceding month's length
	iwf=0
	if (id .lt. is) 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	! of the month, then keep adding
	    is = is + 7			! 7 until we get to the week we
	    go to 11			! want.
	end if
 301	continue
c since we can wrap months down as well as up construct date limits here...
	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.
c
	lohash=((((iy-81)*12)+im)*32)+is
	iss = is			! don't lose track of Sunday's date.
					! It will be important later...
c
c	Now figure out where to write the dates of the days of the week,
c	and write em out where they belong:
c
	call idate(imx,idx,iyx)	!	initialize to today's date

	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
			write(iterm,130,err=99)
	1		    esc,'[4;7m', im,is,iy, esc,resetvattr
		    else
			write(iterm,130,err=99)
	1		    esc,revattr, im,is,iy, esc,resetvattr
		    end if
		else
		    go to 684
		end if
	    else
 684		if (is .eq. id) then
		    write(iterm,130,err=99)
	1		esc,'[4m', im,is,iy, esc,resetvattr
		else
		    write(iterm,13,err=99) im,is,iy
		end if
	    endif

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

	hash=((((iy-81)*12)+im)*32)+is	! 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
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 bytes and store this
c	information by bits instead of bytes.  Oh well.  There
c	goes 100 bytes of storage space...
c	When life confronts you with its troubles and woes,
c	Have no fear, just fire photon torpedos!
c

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
c		Su Mo Tu We Th Fr Sa
c
c	8:00     T  F  F  F  F  F  F	! Appointment on Su at 8:00
c	8:30     F  T  T  T  F  F  F	! Appointments on Mo, Tu, We at 8:30
c	9:00     F  F  F  F  F  F  F	! No appointments at 9:00 this week
c	9:30
c
c	 .	 .  .  .  .  .  .  .
c	 .	 .  .  .  .  .  .  .		etcetera
c	 .	 .  .  .  .  .  .  .
c					! sic itur ad astra
c
c	Etcetra.  Caveat emptor and three other latin words.
c
c

	close(1)
	Open (unit=1, file=FNAME, status='OLD', form='FORMATTED',
	1    readonly, err=999)
	iunit=1
c======================	file reading loop ==============================!
	issss=iss
 111	Continue    ! ===================================================
	    Read(iunit, 115, end=122) ihy, ihm, ihd, iht, iaptx, appoin	!
 115	    format(3i2, i3, q, 100a1)					!

	if (ihm .eq. 99) then

	    call fnscan (appoin, iaptlim, iaptx, ij)
	    if (ij .ne. 0) then
		iunit=2

		Open(unit=iunit, file=appoin, status='old',
	1	    form='formatted', readonly, err=1066)

	    end if

	else

c check for legality based on date from sunday..
c must account for month/year wraps
c	lohash=((((iy-81)*12)+im)*32)+is
	    idhash=((((ihy-81)*12)+ihm)*32)+ihd
	    if ((idhash .ge. lohash) .and. (idhash .le. hash)) then
C	    If (( ihm .eq. im ) .and. ( ihy .eq. iy ) .and.		!
C     1		( ihd .ge. iss ) .and. ( ihd .le. (iss+7) )) 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)
c ***		    jy = iht / 10					!
c ***		    if ( jy .gt. 7 ) jy = jy - 7			!
c ***		    If (((iht/10)*10) .eq. iht) then			!
c ***			jy = 2 * jy - 1					!
c ***		    else						!
c ***			jy = jy * 2					!
c ***		    end if						!
		  if (jx .ge. 1 .and. jx .le. 7 .and.
     1               jy .ge. 1 .and. jy .le. 19) then
c ***		    if (rdspfg .eq. 0) then
c ***		    apts(jx,jy) = .true.				!
c ***		    else
c ***		    apts(jx,jy)= .false.
c ***		    end if

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

D		else
D		write(iterm,7700)jx,jy,ihd,iht,iss,ihy,ihm
D7700	format(' X,Y=',2I4,' Day, tim, ISS, yr, mo= ',5I6)
		  end if
	    End If							!
	end if

	go to 111			! Loop through appointment file(s)!

 122	Continue    !====================================================

	if (iunit .ne. 1) then
 1066	    close(2)
	    iunit=1
	    go to 111
	end if

	close(1)
c
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				! Go through the entire
	    Do j=1,19				! array and display
		If ( apts(i,j) ) then		! appts if they exist:
		    jx = 6 * j + 10		! jx is x coord of cursor
		    jy = 3 * i - 1		! jy is y coord of cursor

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

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

 999	call dtcat(1,22)			! move cursor to the bottom
	return					! of the screen and return
	end
#-h- month.for       9295  asc  25-apr-85 11:53:46  garman
c-----------------------------------------------------------------------
c
c	Month-at-a-glance subroutine
c
c	part of Mitch Wyle's DTC program
c
c	Input: 
c		line 	- 	72 byte string;  Format: M [dd[19[yy]]]
c
c	Output:
c		display screen (see below)
c
c  Line
c     1	Prevmonth			Nextmonth
c     2 SMTWTFS				SMTWTFS
C   3-8 Calendar     (7) Y e a r	Calendar
c     9 		M o n t h
c    11		      S M T W T F S
c 13-23		     C a l e n d a r
c
c Odd lines 9-23 are double-width
c Even lines 10-22 are blank
c
c-----------------------------------------------------------------------
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 MISCHY subr)
c		Months mixed-case and centered (GABY)
c
	SUBROUTINE month	! (line)

c
c	Declarations:
c

	include 'comdtc.inc/nolist'
	include 'escdtc.inc/nolist'
c
c	byte line(1)		!	input line
	byte temp(2)		!	temporary string converting array
c	byte esc /"033/		!	escape character
c	integer iterm/6/	!	Terminal unit number
	integer	id		!	Julian Day
	integer im		!	Julian Month
	integer iy		!	Julian Year
	byte monthn(9),		!	string month name
	1 lmonth(9)
	logical*1 lmneven(12)/	!	Entries true if length of name is even
	1 .false., .true., .false., .false., .false., .true.,
	2  .true., .true., .false., .false., .true.,  .true./
	logical*1 lmnodd(12)	!	Entries true if length of name is odd
	1 /.true., .false., .true., .true.,  .true., .false.,
	2 .false., .false., .true., .true., .false., .false./
	Byte out(79)		!	The output string and * array
        byte rchr		!	Flag set (or reset) character
	byte ln1		!	Same as line(1)
	byte appoin(icmln)	!	Appointment string

	equivalence (line, ln1)
c
c	Initialize:
c

c	iterm = 6		!	Output terminal unit number
c	esc = "033		!	Escape character
c
c		Trim off the M from command line:

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

	call dtcdatcvt(2)	! Decode date string

	im=idmo			! Pick up result from common
	id=iddy
	iy=idyr
c
	call idate(irm,ird,iry)	! Real month,day,year, for display highlight

c ***
c
c		Trim off the M from command line:
c

c ***	    IENDER=1
c ***	    DO 63 I=2,10
c ***	    if (LINE(I) .NE. ' ' .AND. LINE(I) .NE. '	') GO TO 64
c ***	    IENDER=IENDER+1
c *** 63	    CONTINUE
c *** 64	    Do 1 i=1,70
c ***		line(i) = line(i+IENDER)
c *** 1	    Continue

c ***	Call datmun(2)
c
c
c		If the month was specified in command line then
c		set im and iy to the right values:
c

c ***	If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
c ***	    temp(1) = line(1)
c ***	    temp(2) = line(2)
c ***	    decode ( 2 , 2 , temp ) im
c ***	IDMO=IM
c ***	End If
c ***	If ( ( line(3) .ge. '0' ) .and. ( line(4) .le. '9' ) ) then
c ***	    temp(1) = line(3)
c ***	    temp(2) = line(4)
c ***	    decode ( 2 , 2 , temp ) iy
c ***	IDYR=IY
c ***	End If
c *** 2	Format(i2)

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

	write(iterm,600) esc,homescrn, esc,clrscrn
 600	format ('+', 4a, $)

c
c		Now start building the output string: (out)
c

c	Do 3 i=1,79
c	    out(i) = ' '
c 3	Continue

c	out(35) = '1'
c	out(37) = '9'
	encode( 2 , 20 , temp, err=11 ) iy
 11	continue
 20	format(i2.2)
c	out(39) = temp(1)
c	out(41) = temp(2)

c
c Calculate nominal prev, next month numbersc
c
	lm = im - 1
	ly = iy
	nm = im + 1
	ny = iy
c
	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 gaby(lm,lmonth)

c	j = 0
c	Do 4 i=3,19,2
c	    j = j + 1
c	    out(i) = monthn(j)
c 4	Continue

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

c	j = 61					! Set first index
c	Do 5 i=1,9
c	    ! j = (i*2)-1 !!!!
c	    out(j) = monthn(i)
c	    j = j + 2
c 5	Continue
C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS
	ix = 3
	if (lmneven(lm)) ix = ix + 1
	call dtcat(ix, 1)
	write(iterm,6) lmonth
	ix = 61
	if (lmneven(nm)) ix = ix + 1
	call dtcat(ix, 1)
	write(iterm,6) monthn
 6	format ('+', 9(a1, x), $)
	call dtcat(1, 2)
	write(iterm,7)
 7	format('+','Su Mo Tu We Th Fr Sa',T60,'Su Mo Tu We Th Fr Sa',$)
	call dtcat(36, 7)			! Center year above cur month
	write(iterm,96) temp
 96	format ('+', '1 9 ', a1, x, a1)

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

c	If ( im .eq. 1 ) then
c	    lm = 12
c	    ly = iy - 1
c	Else
c	    lm = im - 1
c	    ly = iy
c	End If
c
c	If ( im .eq. 12) then
c	    nm = 1
c	    ny = iy + 1
c	Else
c	    nm = im + 1
c	    ny = iy
c	End If

c
c Last month to upper-left corner of screen
c
	call dany(ib,il,lm,ly)
	call mischy(ib,il,0,0,-1,0)
	If ((irm .eq. lm) .and. (iry .eq. ly)) then	! today in rev video
	    irdw = mod (ird + ib - 2, 7)		! Day of week (orig 0)
	    irwk = (ird + ib - 2)/7			! Week in month (orig 0)
	    call dtcat ((irdw*3) + 1, irwk + 3)
	    write (iterm,684) esc,revattr, ird, esc,resetvattr
	end if
c
c Next month to upper-right corner of screen
c
	call dany(ib,il,nm,ny)
	call mischy(ib,il,58,0,-1,0)
	If ((irm .eq. nm) .and. (iry .eq. ny)) then	! today in rev video
	    irdw = mod (ird + ib - 2, 7)		! Day of week (orig 0)
	    irwk = (ird +ib - 2)/7			! Week in month (orig 0)
	    call dtcat ((irdw*3) + 59, irwk + 3)
	    write (iterm,684) esc,revattr, ird, esc,resetvattr
	end if

c
c		display big banner header name of this month:
c
	ix = 11
	if (lmneven(im)) ix = ix + 1
	call dtcat(ix,9)
	call gaby(im,monthn)
	write(iterm,8) esc,dwide, monthn
 8	format('+',2a, 9(x,a1), $)
9	Continue

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

C	call dtcat(1,9)
	call dtcat(1,11)
c	write(iterm,10)
c 10	format('+',
c	1 'Sunday      Monday     Tuesday   Wednesday    ',
c	2 'Thursday      Friday    Saturday', $)
	write(iterm,10), esc,dwide
 10	format('+', 2a,
	1 'Sun   Mon  Tues  Weds Thurs   Fri   Sat', $)
c	   x     x     x     x     x     x     x     x
c
c Set up header so day numbers will be right-justified under day names
c
c   Sunday    Monday   Tuesday  Wednesday  Thursday   Friday   Saturday
c     nn        nn        nn        nn        nn        nn        nn
c
c 10	format(/,8x,'SUNDAY',3X,'MONDAY',3X,'TUESDAY',2X,'WEDNESDAY',3X,
c	1  'THURSDAY',5X,'FRIDAY',3X,'SATURDAY',/)
c
	write (iterm,138)			! Mark double-width lines
	1 esc,'[13H', esc,dwide,
	2 esc,'[15H', esc,dwide,
	3 esc,'[17H', esc,dwide,
	4 esc,'[19H', esc,dwide,
	5 esc,'[21H', esc,dwide,
	6 esc,'[23H', esc,dwide
 138	format ('+', 24a, $)
c
	call dany(ib,il,im,iy)
c	call mischy(ib,il,8,8,8,1)
	call mischy(ib,il,1,3,9,1)
c
	If ((irm .eq. im) .and. (iry .eq. iy)) then	! today in rev video
c
	    irdw = mod (ird + ib - 2, 7)		! Day of week (orig 0)
	    irwk = (ird + ib - 2)/7			! Week in month (orig 0)
	    call dtcat ((irdw*6)+2, (irwk*2)+13)

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

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

	else

 685	    irdw = mod (id + ib - 2, 7)		! Day of week (orig 0)
	    irwk = (id + ib - 2)/7			! Week in month (orig 0)
	    call dtcat ((irdw*6)+2, (irwk*2)+13)
	    write (iterm,684) esc,'[4m', id, esc,resetvattr

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

	if (rdspfg .eq. 0) then
		rchr='*'
		out(1) = ' '
	else
		rchr=' '
		out(1) = '*'
	end if
c
	Do 110 i=2,31		! set the out array to all blanks:
c	 if (rdspfg .eq. 0) then
c	    out(i) = ' '
c	 else
c	    out(i)='*'
c	 end if
	out(i) = out(1)
 110	continue
C CLOSE UNIT 1, JUST IN CASE IT WAS OPEN...
	CLOSE(1)
	Open (unit=1, file=FNAME, status='OLD', form='FORMATTED',
	1    readonly, err=999)
	iunit=1

 111	Continue    ! ===================================================
	    Read(IUNIT, 115, end=122) ihy, ihm, ihd, iht, iaptx, appoin	!
 115	    format(3i2, i3, q, 100a1)					!

c single indirection if year = 99
c this permits use of multiple data files for scheduling purposes
c maintained by an editor. Note the format is
c999999999filename=
c where
c filename may be absolutely any file spec whatever...

	if ((iunit .eq. 1) .and. (ihm .eq. 99)) then
	    call fnscan(appoin, iaptlim, iaptx, ij)
	    if (ij .ne. 0) then

		iunit=2

		Open(unit=iunit, file=appoin, status='old',
	1	    readonly, form='formatted', err=1066)

	    end if
									!
	else If (( ihm .eq. im ) .and. ( ihy .eq. iy )) then
	    out(ihd) = rchr  						!
	end if

	goto 111							!

 122	Continue    !====================================================
	if (iunit .ne. 1) then
 1066	    close(2)
	    iunit=1
	    goto 111
	end if

	close(1)

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			!	increment day number
	    If ( ip .gt. 7 ) then	!	is it Sunday again?
		ip = 1			!	reset day to Sunday.
		iy = iy + 2 		!	move down one line
	    End If

	    if (out(i) .ne. ' ') then	! Write only non-blank entries !!!!
c		ix = 11 * ip - 3
		ix = 6 * ip - 5
		call dtcat(ix,iy)	!	position cursor
		write(iterm,231) out(i)	!	write * to screen
 231		format('+',a1, $)
	    end if
	end do				! # days in month
	
 999	call dtcat(1,23)		! Position for next prompt

	return
	end
#-h- strip.for       6183  asc  25-apr-85 11:53:48  garman
c-----------------------------------------------------------------------
c
c	Strip Daily Appointment subroutine (DTC Purge command)
c
c	part of GLENN EVERHART'S MODS TO DTC program
c
c	Input: command line - 72 bytes, format:
c
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
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
c-----------------------------------------------------------------------
c

	SUBROUTINE strip		! (line)

c
c	Declarations:
c
	include 'comdtc.inc/nolist'
c
	parameter idspp = 1,	!	Function constants: Purge
	1	  idspu = 2,	!	.. Unschedule
	2	  idspx = 3	!	.. eXchange
c
c	byte line(1)		!	input line
	byte temp(2), ll,	!	temporary string converting array
	1 ln1, ap1
	byte appoin(icmln)	!	appointment string
c	byte esc		!	escape character
	integer	id, idx		!	Julian Day
	integer im, imx		!	Julian Month
	integer iye, iyx	!	Julian Year
	integer it1, it2, itx1, itx2	! time values 80 (8 AM) => 173 (5:30 PM)
c
	integer ihy, ihm, ihd, iht	! Values from input record
	logical first		!	For X decode
	equivalence (line, ln1), (appoin, ap1)
c
	include 'stmtfunc.for/nolist'	! Get standard statement functions
c
c	Initialize:
c

c	iterm = 6		!	Output terminal unit number
c	esc = "033		!	Escape character
c


c
c		Parse that line!
c

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

	isavinc = incmod		! Save for increment in DATCVT

	first = .true.			! Set it regardless of path

	If ( ln1 .eq. 'P' ) then

	    idisp = idspp		! Function to perform

	else

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

	    it1 = 80			! Set comparison values
	    it2 = 174
	    itx1 = it1
	    itx2 = it2

	End If

	call shrink (1, ifnb, lnb)

	if (ifnb .eq. 0) then
	    if (idisp .eq. idspp) then
		call idate(im,id,iye)	! set to today's date
	    else
		go to 999		! Not enough info for U or X
	    end if
	else
c
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)			! (line)

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

	    if (idisp .ne. idspp) then	! other than purge
		call dtctimcvt(itx1, itx2)
		itx2 = itx2 + 1		! 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	! Error if nothing left
			first = .false.
			go to 10		! Re-cycle code
		    end if			! Done unless X
		end if
	    else				! P, guarantee no redisplay
		ln1 = "0			! Zap the line
	    end if				! Done parse for U, X
	end if					! Done date/time parse
c
	khsh = ((((iye-81) * 12) + im) * 32) + id

c	khsh=id+32*(im+12*(iye-81))	! Compute value for comparison
c
c add close to guarantee no failures...
c
	close(1)
	Open (unit=1, file=FNAME, status='OLD', form='FORMATTED',
	1     readonly, carriagecontrol='LIST', err=99)
c
	close(2)
	open(unit=2, file=FNAME, status='NEW', form='FORMATTED',
	1    carriagecontrol='LIST', err=999)

	irecno = 0	! Counters for # records read
	iwrtno = 0	! .. written (# deleted = read - write)
	ichgno = 0	! .. rescheduled
c
 100	continue	!	loop back up here to continue reading and
			!	processing input file:


	read (1, 200, end=400) ihy, ihm, ihd, iht, km, appoin
 200	format(3i2, i3, q, 100a1)	! nnA1, > = actual length of LINE
c
	irecno = irecno + 1
c	write (6, 98) irecno		! Debug
c 98	format ('+', i5)		! Debug
c
	lhsh = ((((ihy-81) * 12) + ihm) * 32) + ihd
c	lhsh=ihd+32*(ihm+12*(ihy-81))	! Calc comparison date for input
c
c ************************************* dispatch here for P/U/X
c
	iht = min0(max0(iht, 80), 173)	! Insure a kosher time value

	go to (110, 120, 130) idisp	! Dispatch on numeric value

 110	if (lhsh .lt. khsh) go to 100	! Purge, don't re-write if before
	go to 190			! Do re-write

 120	if ((lhsh .eq. khsh) .and.
	1   ((iht .ge. it1) .and. (iht .le. it2)))
	2  go to 100			! Criteria for Unscheduling (deleting)
	go to 190			! Do re-write

 130	if ((lhsh .eq. khsh) .and.
	1   ((iht .ge. it1) .and. (iht .le. it2))) then

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

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

	    ichgno = ichgno + 1		! Count rescheds

	    ihy = idyr			! Change dates
	    ihm = idmo
	    ihd = iddy

	end if				! Usually re-write
c
 190	iwrtno = iwrtno + 1		! Count

	do kk = min0(max0(km, 1), iaptlim + 1), 1, -1	! search from back end
	    if (appoin(kk) .gt. ' ')
	1	go to 220			! found non-blank
	end do					! dumps trailing NULs also

	kk = 1				! Empty text record
	appoin(1) = ' '			! Force one blank
	go to 230
c
 220	do kl = 1, kk
	    if (appoin(kl) .ne. ' ') 
	1	go to 210			! Leading CTL-x OK
	end do

 230	kl = kk

 210	kk = min0(kk, kl + (iaptlim-1))

	write (2, 201) ihy, ihm, ihd, iht, (appoin(k), k=kl,  kk)
 201	format(3i2.2, i3.3, x, 100a1)

	go to 100

 400	continue	! no more appointments left in file.

	close(1)
	close(2)

	if (idisp .eq. idspx) then
	    write (iterm, 490, err=410) ichgno	! Show rescheds
 410	    if (ln1 .eq. 0) then	! If no redisplay
		idyr = iye		! Restore first set of dates
		idmo = im
		iddy = id
		incmod = isavinc
	    end if			! Else show results of resched
	end if

	write (iterm, 495, err=420) irecno - iwrtno	! purge/delete/discard

 420	return

 490	format('+', i3, ' appts resched, ', $)
 495	format('+', i3, ' appts deleted.', $)

 99	continue	! Error opening file, nothing to do, create empty
c
	open(unit=1, file=FNAME, status='NEW', form='FORMATTED',
	1    carriagecontrol='LIST')
	close(1)
c
	return

 999	write (iterm, 990)		! Error on decode, write nastygram
 990	format('+Syntax or file error.', $)
	ln1 = "0			! Inhibit rescan
c
	end