home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.update.uu.se
/
ftp.update.uu.se.2014.03.zip
/
ftp.update.uu.se
/
pub
/
rainbow
/
msdos
/
decus
/
RB101
/
week.for
< prev
next >
Wrap
Text File
|
1995-05-19
|
11KB
|
468 lines
$STORAGE: 2
$NOFLOATCALLS
c-----------------------------------------------------------------------
c
c Week-at-a-glance subroutine
c
c part of Mitch Wyle's DTC program
c
c Input:
c line - 72 character string; Format: W [mmddyy]
c
c Output:
c display screen (see below)
c
c-----------------------------------------------------------------------
c
SUBROUTINE week(line)
c
c Declarations:
c
character line(1)
c input line
character temp(2)
c temporary string converting array
character*2 temp2
equivalence (temp(1),temp2)
character esc
c escape character
character appoin(60)
character*20 appoi6
equivalence (appoin(1),appoi6)
c appointment array
logical apts(7,19)
INTEGER HASH
integer id
c Julian Day
integer im
c Julian Month
integer iy
c Julian Year
C LENGTHS OF MONTHS ... KLUGE ... FORGET LEAP YEARS...
INTEGER*2 ML(14)
integer rdspfg
c flag to reverse sense of display of time
integer ctlfg
c misc control flags here
INTEGER IDYR,IDMO,IDDY
COMMON/DEFDAT/IDYR,IDMO,IDDY
common/ctls/rdspfg,ctlfg
character fname(60)
character*20 fnam60
equivalence(fname(1),fnam60)
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
c impossible saved Sunday day...
iterm = 0
c Output terminal unit number
esc = 27
c Escape character
IWF=0
IM=IDMO
ID=IDDY
IY=IDYR
C call idate(im,id,iy)
c 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
c clear any apointments from
Do 1110 j=1,19
c 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)
read(temp2,2)im
c decode ( 2 , 2 , temp ) im
temp(1) = line(3)
temp(2) = line(4)
read(temp2,2)id
c decode ( 2 , 2 , temp ) id
temp(1) = line(5)
temp(2) = line(6)
read(temp2,2)iy
c 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
intsz=0
intsz=khar(line(lft))
intsz=intsz-48
c intsz=line(lft)-48
c DECODE(1,931,LINE(LFT),ERR=1113)INTSZ
ELSE
intsz=0
intsz=khar(line(lft))
intsz=intsz-48
intsz=intsz*10
kkkk=0
kkkk=khar(line(lft+1))
kkkk=kkkk-48
intsz=intsz+kkkk
c intsz=(line(lft)-48)*10)+(line(lft+1)-48))
c 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,'[','2','J',esc,'[','0','1',';','0',
1 '1','H'
6 format(1x,79a1,\)
Do 8 i=1,7
write(iterm,7)
7 format(1x,78('-'),2(/,1x,'|',77x,'|'),\)
8 Continue
write(iterm,9)
9 format(1x,78('-'),\)
call dtcat(2,2)
write(iterm,10) 'Sunday'
10 format(1X,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)
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.
C NO...SUNDAY MAY BE IN PRECEDING MONTH
end if
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)
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
c of the month, then keep adding
is = is + 7
c 7 until we get to the week we
goto 11
c 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
c don't lose track of Sunday's date.
c 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
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
End If
End If
C SAVE LAST DAY VALUE IN HASH
HASH=IS+32*(IM+12*(IY-81))
12 continue
13 format(1X,2(i2,'/'),i2,\)
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 characters and store this
c information by bits instead of characters. Oh well. There
c goes 100 characters of storage space...
c When life confronts you with its troubles and woes,
c Have no fear, just fire photon torpedos
c
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
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 . . . . . . . .
c . . . . . . . . etcetera
c . . . . . . . .
c
c sic itur ad astra
c
c Etcetra. Caveat emptor and three other latin words.
c
c
22 close(1)
Open (1,file=FNAM60,status='OLD',form='FORMATTED')
iunit=1
c====================== file reading loop ==============================
c
ISSSS=ISS
111 Continue
c ===================================================
Read(iunit,115,end=122,ERR=122)ihy,ihm,ihd,iht,
1 (appoin(k),k=1,60)
c
115 format(3i2,i3,60a1)
c
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)=32
KKK=0
do 1068 ii=1,59
IF(APPOIN(II).EQ.'='.OR.APPOIN(II).LE.31)KKK=1
IF(KKK.GT.0)APPOIN(II)=32
C if(appoin(ii).eq.'=')appoin(ii)=0
1068 continue
Open(iunit,file=appoi6,status='old',form='formatted')
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
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
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
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
c
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.
c
else
apts(jx,jy)=.false.
end if
END IF
End If
c
goto 111
c
122 Continue
c ====================================================
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
c Go through the entire
Do 18 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(iterm,16) jj
c it falls on the hour.
16 format(1X,i2,':00')
else
jj = jj + 7 - (jj/2)
c If the time is even then
write(iterm,17) jj
c it falls on the half hour
17 format(1X,i2,':30')
end if
End If
18 Continue
19 Continue
call dtcat(1,22)
c move cursor to the bottom
return
c of the screen and return
end