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 >
Text File  |  1995-05-19  |  11KB  |  468 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c-----------------------------------------------------------------------
  4. c
  5. c    Week-at-a-glance subroutine
  6. c
  7. c    part of Mitch Wyle's DTC program
  8. c
  9. c    Input: 
  10. c        line     -     72 character string;  Format: W [mmddyy]
  11. c
  12. c    Output:
  13. c        display screen (see below)
  14. c
  15. c-----------------------------------------------------------------------
  16. c
  17.  
  18.     SUBROUTINE week(line)
  19.  
  20. c
  21. c    Declarations:
  22. c
  23.  
  24.     character line(1)        
  25. c     input line
  26.     character temp(2)        
  27. c     temporary string converting array
  28.     character*2 temp2
  29.     equivalence (temp(1),temp2)
  30.     character esc        
  31. c     escape character
  32.     character appoin(60)        
  33.     character*20 appoi6
  34.     equivalence (appoin(1),appoi6)
  35. c     appointment array
  36.     logical apts(7,19)
  37.     INTEGER HASH
  38.     integer    id        
  39. c     Julian Day
  40.     integer im        
  41. c     Julian Month
  42.     integer iy        
  43. c     Julian Year
  44. C LENGTHS OF MONTHS ... KLUGE ... FORGET LEAP YEARS...
  45.     INTEGER*2 ML(14)
  46.     integer rdspfg          
  47. c   flag to reverse sense of display of time
  48.     integer ctlfg           
  49. c   misc control flags here
  50.     INTEGER IDYR,IDMO,IDDY
  51.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  52.     common/ctls/rdspfg,ctlfg
  53.     character fname(60)
  54.     character*20 fnam60
  55.     equivalence(fname(1),fnam60)
  56.     integer fnsz
  57.     common/fn/fnsz,fname
  58.     DATA ML/31,31,28,31,30,31,30,31,31,30,31,30,31,31/
  59.  
  60. c
  61. c    Initialize:
  62. c
  63.  
  64.     iss=999                 
  65. c        impossible saved Sunday day...
  66.     iterm = 0        
  67. c     Output terminal unit number
  68.     esc = 27        
  69. c     Escape character
  70.     IWF=0
  71.     IM=IDMO
  72.     ID=IDDY
  73.     IY=IDYR
  74. C    call idate(im,id,iy)    
  75. c     initialize to today's date
  76. C Where we look for free space of n units or more length,
  77. C then just display reverse and zot out all shorter periods
  78.     IF(CTLFG.eq.1)RDSPFG=1
  79.     Do 1111 i=1,7        
  80. c     clear any apointments from
  81.        Do 1110 j=1,19    
  82. c     other weeks.
  83.         if(rdspfg.eq.0) then
  84.            apts(i,j) = .false.
  85.         else
  86.            apts(i,j)=.true.
  87.         end if
  88. 1110       Continue
  89. 1111    Continue
  90.  
  91. c
  92. c        Trim off the W from command line:
  93. c
  94.  
  95.     Do 1 i=1,70
  96.         line(i) = line(i+2)
  97. 1    Continue
  98.     CALL DATMUN(LINE)
  99. c
  100. c        If the date was specified in command line then
  101. c        set id, im and iy to the right values:
  102. c
  103.  
  104.     lft=1
  105.     If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
  106.         lft=8
  107.         temp(1) = line(1)
  108.         temp(2) = line(2)
  109.     read(temp2,2)im
  110. c        decode ( 2 , 2 , temp ) im
  111.         temp(1) = line(3)
  112.         temp(2) = line(4)
  113.     read(temp2,2)id
  114. c        decode ( 2 , 2 , temp ) id
  115.         temp(1) = line(5)
  116.         temp(2) = line(6)
  117.     read(temp2,2)iy
  118. c        decode ( 2 , 2 , temp ) iy
  119.     IDMO=IM
  120.     IDDY=ID
  121.     IDYR=IY
  122.     End If
  123. 2    Format(i2)
  124. 931    FORMAT(I1)
  125.     If(ctlfg.ne.0)then
  126.       IF(LINE(LFT).LT.'0')LINE(LFT)='0'
  127.       IF(LINE(LFT+1).LT.'0'.OR.LINE(LFT+1).GT.'9')THEN
  128.     intsz=0
  129.     intsz=khar(line(lft))
  130.     intsz=intsz-48
  131. c    intsz=line(lft)-48
  132. c          DECODE(1,931,LINE(LFT),ERR=1113)INTSZ
  133.       ELSE
  134.     intsz=0
  135.     intsz=khar(line(lft))
  136.     intsz=intsz-48
  137.     intsz=intsz*10
  138.     kkkk=0
  139.     kkkk=khar(line(lft+1))
  140.     kkkk=kkkk-48
  141.     intsz=intsz+kkkk
  142. c    intsz=(line(lft)-48)*10)+(line(lft+1)-48))
  143. c      decode(2,2,line(lft),err=1113)intsz
  144.       END IF
  145. 1113      continue
  146.       if(intsz.le.0)intsz=1
  147.       if(intsz.gt.18)intsz=18
  148. c clamp interval size to permissible range...
  149.     end if
  150. c
  151. c        Paint the screen:
  152. c
  153.  
  154. c following sequence sets screen to ANSI mode, clears it, and moves to
  155. c upper left corner on VT100 compatible terminals.
  156.     write(iterm,6) esc,'[','2','J',esc,'[','0','1',';','0',
  157.      1  '1','H'
  158. 6    format(1x,79a1,\)
  159.  
  160.     Do 8 i=1,7
  161.         write(iterm,7)
  162. 7        format(1x,78('-'),2(/,1x,'|',77x,'|'),\)
  163. 8    Continue    
  164.     write(iterm,9)
  165. 9    format(1x,78('-'),\)
  166.     call dtcat(2,2)
  167.     write(iterm,10) 'Sunday'
  168. 10    format(1X,a,\)
  169.     call dtcat(2,5)
  170.     write(iterm,10) 'Monday'
  171.     call dtcat(2,8)
  172.     write(iterm,10) 'Tuesday'
  173.     call dtcat(2,11)
  174.     write(iterm,10) 'Wednesday'
  175.     call dtcat(2,14)
  176.     write(iterm,10) 'Thursday'
  177.     call dtcat(2,17)
  178.     write(iterm,10) 'Friday'
  179.     call dtcat(2,20)
  180.     write(iterm,10) 'Saturday'
  181.  
  182. c
  183. c    Now figure out which Sunday is closest to the day specified by id:
  184. c
  185.  
  186.     call dany(ib,il,im,iy)        
  187. c  Remember: ib = 1st day of month
  188. C IL = LENGTH OF MONTH
  189. c ib = day number of 1st day of month, 1=sunday.
  190.     if ( ib .eq. 1 ) then
  191.         is = 1            
  192. c  is is the Sunday we want.  It is
  193.     else                
  194. c  either the 1st day of the month
  195.         is = 9 - ib            
  196. c  or 9 - 1st day of month.
  197. C NO...SUNDAY MAY BE IN PRECEDING MONTH
  198.     end if
  199.  
  200. 11    continue            
  201. c  If the day is not in the 1st week
  202. C TRY TO FIX UP CASE OF WRONG SUNDAY..
  203. C ML ARRAY IS PRECEDING MONTH'S LENGTH
  204.     IWF=0
  205.     IF(ID.LT.IS) THEN
  206.         IS=IS-7+ML(IM)
  207. c in leap years (IY/4 even) then ML(3) is Feb. entry and is 29, not 28.
  208. c adjust here.
  209.         IF((IY/4)*4.EQ.IY.AND.IM.EQ.3)IS=IS+1
  210.         IM=IM-1
  211.         IF(IM.LE.0) THEN
  212. C ADJUST YEAR WRAPBACK
  213.             IM=12
  214.             IY=IY-1
  215.         END IF
  216.         IL=ML(IM+1)
  217.         IWF=-IL
  218.         GOTO 301
  219.     END IF
  220.     if ( ( id - is ) .ge. 7 ) then    
  221. c  of the month, then keep adding
  222.         is = is + 7            
  223. c  7 until we get to the week we
  224.         goto 11            
  225. c  want.
  226.     end if
  227. 301    CONTINUE
  228. C SINCE WE CAN WRAP MONTHS DOWN AS WELL AS UP CONSTRUCT DATE LIMITS HERE...
  229.     IF(IY.GT.1900)IY=IY-1900
  230. C JUST GENERATE A HASHCODE THAT IS STRICTLY INCREASING AS A FUNCTION OF
  231. C DATE. ONLY PURPOSE IS TO BE MONOTONIC INCREASING, SO CONTINUITY IS
  232. C NOT IMPORTANT. WE USE OTHER METHODS TO HANDLE EXACT OFFSETS. NOTE THAT
  233. C WHERE WRAP AROUNDS OCCUR, ISS IS ALLOWED TO BE A LITTLE LARGER THAN
  234. C REAL MONTH LENGTH OR A SMALL NEGATIVE WHERE USED BELOW...NOT HERE.
  235.     LOHASH=IS+32*(IM+12*(IY-81))
  236.     iss = is            
  237. c  don't lose track of Sunday's date.
  238.                     
  239. c  It will be important later...
  240. c
  241. c    Now figure out where to write the dates of the days of the week,
  242. c    and write em out where they belong:
  243. c
  244.  
  245.     Do 12 i=1,7
  246.         jy = 3 * i
  247.         call dtcat(2,jy)
  248.         write(iterm,13) im,is,iy
  249.         is = is + 1
  250.         If ( is .gt. il ) then        
  251. c  Did the month change
  252.         is = 1                
  253. c  during this week?
  254.         im = im + 1
  255.         If ( im .gt. 12 ) then        
  256. c  Did the year change
  257.             im = 1            
  258. c  during this week?
  259.             iy = iy + 1
  260.         End If
  261.         End If
  262. C SAVE LAST DAY VALUE IN HASH
  263.     HASH=IS+32*(IM+12*(IY-81))
  264. 12    continue
  265. 13    format(1X,2(i2,'/'),i2,\)
  266.  
  267. c
  268. c        Now for Files I/O:
  269. c
  270.  
  271. c    Set up a boolean array of appointment times and days of
  272. c    the week.  Notice that if this program were written in
  273. c    assembler, we would use only 18 characters and store this
  274. c    information by bits instead of characters.  Oh well.  There
  275. c    goes 100 characters of storage space...
  276. c    When life confronts you with its troubles and woes,
  277. c    Have no fear, just fire photon torpedos
  278. c 
  279. c
  280.  
  281. c
  282. c    Read the appointments; If the appointment is for one of
  283. c    the days in this week, mark that spot in the appointments
  284. c    array true.  Otherwise that coordinate is false.  The array 
  285. c    looks like this:
  286. c
  287. c        Su Mo Tu We Th Fr Sa
  288. c
  289. c    8:00     T  F  F  F  F  F  F    
  290. c  Appointment on Su at 8:00
  291. c    8:30     F  T  T  T  F  F  F    
  292. c  Appointments on Mo, Tu, We at 8:30
  293. c    9:00     F  F  F  F  F  F  F    
  294. c  No appointments at 9:00 this week
  295. c    9:30
  296. c
  297. c     .     .  .  .  .  .  .  .
  298. c     .     .  .  .  .  .  .  .        etcetera
  299. c     .     .  .  .  .  .  .  .
  300. c                    
  301. c  sic itur ad astra
  302. c
  303. c    Etcetra.  Caveat emptor and three other latin words.
  304. c
  305. c
  306.  
  307. 22    close(1)
  308.     Open (1,file=FNAM60,status='OLD',form='FORMATTED')
  309.     iunit=1
  310. c======================    file reading loop ==============================
  311. c 
  312.     ISSSS=ISS
  313. 111    Continue    
  314. c  ===================================================
  315.        Read(iunit,115,end=122,ERR=122)ihy,ihm,ihd,iht,
  316.      1  (appoin(k),k=1,60)    
  317. c 
  318. 115        format(3i2,i3,60a1)                        
  319. c 
  320.     if(ihy.eq.99)then
  321.     iunit=2
  322. c null terminate the filename somewhere
  323. c lines with 99 in 1st 2 cols are filenames only...
  324. c use = as delimiter of filename
  325.     appoin(59)=32
  326.     KKK=0
  327.     do 1068 ii=1,59
  328.     IF(APPOIN(II).EQ.'='.OR.APPOIN(II).LE.31)KKK=1
  329.     IF(KKK.GT.0)APPOIN(II)=32
  330. C    if(appoin(ii).eq.'=')appoin(ii)=0
  331. 1068    continue
  332.     Open(iunit,file=appoi6,status='old',form='formatted')
  333.     goto 111
  334.     end if
  335. C CHECK FOR LEGALITY BASED ON DATE FROM SUNDAY..
  336. C MUST ACCOUNT FOR MONTH/YEAR WRAPS
  337. C    LOHASH=IS+32*(IM+12*(IY-81))
  338.     IDHASH=IHD+32*(IHM+12*(IHY-81))
  339.         If ((IDHASH.GE.LOHASH).AND.(IDHASH.LE.HASH))THEN
  340. C        If (( ihm .eq. im ) .and. ( ihy .eq. iy ) .and.        
  341. C     1        ( ihd .ge. iss ) .and. ( ihd .le. (iss+7) )) then    
  342. c 
  343. C NOW we are testing the date range validly. However, we must adjust
  344. C the ISS range to be in the range from - (small #) to +
  345. C (or some such) to take into account the fact that it MUST be
  346. C continuous in order to be transformed into a cursor address.
  347. C FORTUNATELY we saved the appropriate length of month adjustment
  348. C above so can add it back in here.  IWF=0 most times.
  349.             ISS=ISSSS+IWF
  350.             jx = ihd - iss + 1                    
  351. c 
  352. c need a little more logic to handle crossing months here
  353. c where jx >7 we have to adjust by length of month once more...
  354.             if(jx.gt.7)jx=jx+iwf
  355. c also have to handle cases where we crossed months, by adding in
  356. c length of previous month.
  357.             if(jx.le.0)jx=jx+ml(im)
  358.             jy = iht / 10                    
  359. c 
  360.             if ( jy .gt. 7 ) jy = jy - 7            
  361. c 
  362.             If (((iht/10)*10) .eq. iht) then            
  363. c 
  364.             jy = 2 * jy - 1                    
  365. c 
  366.             else                        
  367. c 
  368.             jy = jy * 2                    
  369. c 
  370.             end if                        
  371. c 
  372.           IF(JX.GE.1.AND.JX.LE.7.AND.
  373.      1               JY.GE.1.AND.JY.LE.19) THEN
  374.             if(rdspfg.eq.0) then
  375.             apts(jx,jy) = .true.                
  376. c 
  377.             else
  378.             apts(jx,jy)=.false.
  379.             end if
  380.           END IF
  381.         End If                            
  382. c 
  383.         goto 111                            
  384. c 
  385. 122    Continue    
  386. c ====================================================
  387.     if(iunit.ne.1)then
  388. 1066    close(2)
  389.     iunit=1
  390.     goto 111
  391.     end if
  392.     close(1)
  393. c
  394. c        Now display the information we have extracted:
  395. c
  396.     If(ctlfg.ne.0) then
  397. c here go through and look for "intsz" sized intervals and
  398. c set apts(i,j) to .false. if the interval is too small...
  399.     k=19-intsz
  400.     Do 1120 i=1,7
  401.       Do 1121 j=1,k
  402.         ivl=1
  403.         Do 1122 l=1,intsz
  404.         If(.not.apts(i,j+l-1))ivl=0
  405. 1122    continue
  406.         if(ivl.ne.1)apts(i,j)=.false.
  407. 1121    continue
  408. c since we are showing valid start times, set all times at the end of
  409. c the day false since they can't possibly be valid times for any
  410. c meetings.
  411.       kk=k+1
  412.       if(kk.le.18)then
  413.         do 1126 j=kk,18
  414.           apts(i,j)=.false.
  415. 1126    continue
  416.       end if
  417. 1120    continue
  418.     End If
  419.  
  420.     Do 19 i=1,7                
  421. c  Go through the entire
  422.         Do 18 j=1,19            
  423. c  array and display
  424.         If ( apts(i,j) ) then        
  425. c  appts if they exist:
  426.             jx = 6 * j + 10        
  427. c  jx is x coord of cursor
  428.             jy = 3 * i - 1        
  429. c  jy is y coord of cursor
  430.  
  431.             If ( jx .gt. 74) then    
  432. c  For afternoon and evening
  433.             jy = jy + 1        
  434. c  appointments, put the
  435.             jx = jx - 63        
  436. c  appointments on the second
  437.             End If            
  438. c  line of the day
  439.  
  440.             jj = j            
  441. c  Now decode the time again
  442.             call dtcat(jx,jy)        
  443. c  to display.  jj is time
  444.             if (((j/2)*2) .ne. j) then    
  445. c  of appointment
  446.                 jj = jj + 7 - (jj/2)    
  447. c  If the time is odd then
  448.             write(iterm,16) jj    
  449. c  it falls on the hour.
  450. 16            format(1X,i2,':00')
  451.             else
  452.                 jj = jj + 7 - (jj/2)    
  453. c  If the time is even then
  454.             write(iterm,17) jj    
  455. c  it falls on the half hour
  456. 17            format(1X,i2,':30')
  457.             end if            
  458.         End If
  459. 18        Continue
  460. 19    Continue
  461.     call dtcat(1,22)            
  462. c  move cursor to the bottom
  463.     return                    
  464. c  of the screen and return
  465.     end
  466.  
  467.  
  468.