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 c byte line(1) ! 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(60) ! appointment array logical apts(7,19) INTEGER HASH integer id ! Julian Day integer im ! Julian Month integer iy ! Julian Year C LENGTHS OF MONTHS ... KLUGE ... FORGET LEAP YEARS... INTEGER*2 ML(14) 1 /31,31,28,31,30,31,30,31,31,30,31,30,31,31/ 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 IWF=0 IM=IDMO 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 Do 1111 i=1,7 ! clear any apointments from Do 1110 j=1,19 ! other weeks. if(rdspfg.eq.0) then apts(i,j) = .false. else apts(i,j)=.true. end if 1110 Continue 1111 Continue c c Trim off the W from command line: c IENDER=1 DO 63 I=2,10 IF(LINE(I).NE.' '.AND.LINE(I).NE.' ')GO TO 64 IENDER=IENDER+1 63 CONTINUE 64 Do 1 i=1,70 line(i) = line(i+IENDER) 1 Continue 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 lft=1 If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then lft=8 temp(1) = line(1) temp(2) = line(2) decode ( 2 , 2 , temp ) im temp(1) = line(3) temp(2) = line(4) decode ( 2 , 2 , temp ) id temp(1) = line(5) temp(2) = line(6) decode ( 2 , 2 , temp ) iy IDMO=IM IDDY=ID IDYR=IY End If c 2 Format(i2) 931 FORMAT(I1) If(ctlfg.ne.0)then IF(LINE(LFT).LT.'0')LINE(LFT)='0' IF(LINE(LFT+1).LT.'0'.OR.LINE(LFT+1).GT.'9')THEN DECODE(1,931,LINE(LFT),ERR=1113)INTSZ ELSE decode(2,2,line(lft),err=1113)intsz END IF 1113 continue if(intsz.le.0)intsz=1 if(intsz.gt.18)intsz=18 c clamp interval size to permissible range... end if c c Paint the screen: c c following sequence sets screen to ANSI mode, clears it, and moves to c upper left corner on VT100 compatible terminals. write(iterm,6) esc,homescrn, esc,clrscrn, esc,revattr 6 format('+',6a,$) c write (iterm, 70), so, 'l', 'k', si ! Upper corners & top line c Do 8 i=1,6 write (iterm, 71), so, esc, esc, si write (iterm, 72), so, si 8 Continue c write (iterm, 71), so, esc, esc, si ! two more sides write (iterm, 73), so, 'm', 'j', si ! Lower corners & bottom line write (iterm, 75), esc,resetvattr 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 75 format('+', 2a, $) ! Reset video attributes c c write(iterm,7) c 7 format(x,79('-'),2(/,x,'|',t80,'|')) 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 GOTO 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 goto 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. LOHASH=IS+32*(IM+12*(IY-81)) 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 12 i=1,7 jy = 3 * i call dtcat(2,jy) if ((im .eq. imx) .and. (is .eq. idx) 1 .and. (iy .eq. iyx)) then write(iterm,130,err=99) ! Special display of current day 1 esc,'[4m', im,is,iy, esc,resetvattr else write(iterm,13,err=99) im,is,iy 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 C SAVE LAST DAY VALUE IN HASH HASH=IS+32*(IM+12*(IY-81)) 12 continue c 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='UNKNOWN',form='FORMATTED') iunit=1 c====================== file reading loop ==============================! ISSSS=ISS 111 Continue ! =================================================== Read(iunit,115,end=122) ihy,ihm,ihd,iht,(appoin(k),k=1,60) ! 115 format(3i2,i3,60a1) ! if(ihy.eq.99)then iunit=2 c null terminate the filename somewhere c lines with 99 in 1st 2 cols are filenames only... c use = as delimiter of filename appoin(59)=0 do 1068 ii=1,59 if(appoin(ii).eq.'=')appoin(ii)=0 1068 continue Open(unit=iunit,file=appoin,status='old',form='formatted', 1 err=1066) goto 111 end if C CHECK FOR LEGALITY BASED ON DATE FROM SUNDAY.. C MUST ACCOUNT FOR MONTH/YEAR WRAPS C LOHASH=IS+32*(IM+12*(IY-81)) IDHASH=IHD+32*(IHM+12*(IHY-81)) 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 = iht / 10 ! if ( jy .gt. 7 ) jy = jy - 7 ! If (((iht/10)*10) .eq. iht) then ! jy = 2 * jy - 1 ! else ! jy = jy * 2 ! end if ! IF(JX.GE.1.AND.JX.LE.7.AND. 1 JY.GE.1.AND.JY.LE.19) THEN if(rdspfg.eq.0) then apts(jx,jy) = .true. ! else apts(jx,jy)=.false. end if 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 ! goto 111 ! 122 Continue !==================================================== if(iunit.ne.1)then 1066 close(2) iunit=1 goto 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 1120 i=1,7 Do 1121 j=1,k ivl=1 Do 1122 l=1,intsz If(.not.apts(i,j+l-1))ivl=0 1122 continue if(ivl.ne.1)apts(i,j)=.false. 1121 continue 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 1126 j=kk,18 apts(i,j)=.false. 1126 continue end if 1120 continue End If Do 19 i=1,7 ! Go through the entire Do 18 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 18 Continue 19 Continue call dtcat(1,22) ! move cursor to the bottom return ! of the screen and return end