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 SUBROUTINE week(line) c c Declarations: c byte line(1) ! input line byte temp(2) ! temporary string converting array byte esc ! escape character 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) integer rdspfg ! flag to reverse sense of display of time integer ctlfg ! misc control flags here INTEGER IDYR,IDMO,IDDY COMMON/DEFDAT/IDYR,IDMO,IDDY common/ctls/rdspfg,ctlfg byte fname(60) integer fnsz common/fn/fnsz,fname DATA ML/31,31,28,31,30,31,30,31,31,30,31,30,31,31/ c c Initialize: c iss=999 ! impossible saved Sunday day... iterm = 6 ! Output terminal unit number esc = "033 ! Escape character IWF=0 IM=IDMO ID=IDDY IY=IDYR 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 Do 1 i=1,70 line(i) = line(i+2) 1 Continue CALL DATMUN(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 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,'<',esc,'[','2','J',esc,'[','0','1',';','0', 1 '1','H' 6 format(x,79a1) Do 8 i=1,7 write(iterm,7) 7 format(x,79('-'),2(/,x,'|',t80,'|')) 8 Continue write(iterm,9) 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) c in leap years (IY/4 even) then ML(3) is Feb. entry and is 29, not 28. c adjust here. IF((IY/4)*4.EQ.IY.AND.IM.EQ.3)IS=IS+1 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 Do 12 i=1,7 jy = 3 * i call dtcat(2,jy) write(iterm,13) im,is,iy 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 13 format('+',2(i2.2,'/'),i2.2) 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(6,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