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 / outpt.for < prev    next >
Text File  |  1995-05-19  |  9KB  |  384 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c DR:[333,106]OUTPT.FTN
  4. c
  5. c-----------------------------------------------------------------
  6. c
  7. c    Output subroutine for Mitch Wyle's (and Glenn Everhart's)
  8. c
  9. c        D esk   T op    C alendar   program
  10. c
  11. c    Inputs:
  12. c        line - character array containing date range to output
  13. c
  14. c    Output:
  15. c        DTC.OUT file, to be printed
  16. c
  17. c-----------------------------------------------------------------
  18. c
  19.  
  20. c To the reader of this code:
  21. c
  22. c This routine does NOT perform to specifications.  The date
  23. c range check is incomplete.
  24. c
  25. c
  26. c This code is worse than a kludge; it is DIE code (Designed In Editor)
  27. c The output spec was conceived and coded in the editor, and the algorithm
  28. c to get the output stinks.
  29. c The idea of using an output record a la COBOL is sound.  It is conceptually
  30. c best to build up an array by calls to date functions and subroutines,
  31. c HOWEVER, the coward arrays and repetitive loops are wasteful and unneccessary
  32. c This routine needs a major re-write
  33. c !!!!
  34. c The output specification and format is fine (for my uses); If you do
  35. c re-write this routine, here are some ideas:
  36. c
  37. c    o Include the file indirection to print several calendar files'
  38. c      appointments.
  39. c
  40. c    o build functions which call the subroutine dany; use these functions
  41. c      to make the out array for printing;
  42. c    o eliminate the coward arrays; do fancy math in the code instead
  43. c
  44. c    o Create alternate outputs, such as
  45. c        - Year-At-A-Glance output
  46. c        - collumns or boxes on page with appointments AND blank areas
  47. c          which are free
  48. c
  49. c I apologize for this lousy code; I hope Glenn or somebody cleans it up again.
  50. c
  51.  
  52.     SUBROUTINE OUTPT(line)
  53.  
  54.  
  55.     character line(1)        
  56. c     input line
  57.     character temp(2)        
  58.     CHARACTER*2 TEMP2
  59.     EQUIVALENCE(TEMP(1),TEMP2)
  60. c     temporary string converting array
  61.     character appoin(60)        
  62. c     appointment string
  63.     character work(60)           
  64. c   scratch array for handling scheduling
  65.     character esc        
  66. c     escape character
  67.     integer    id,id2        
  68. c     Julian Day
  69.     integer im,im2        
  70. c     Julian Month
  71.     integer iye,iye2    
  72. c     Julian Year
  73.     integer rdspfg          
  74. c   flag to reverse sense of display of time
  75.     integer ctlfg           
  76. c   misc control flags here
  77.     INTEGER IDYR,IDMO,IDDY
  78.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  79.     common/ctls/rdspfg,ctlfg
  80.     character fname(60)
  81.     integer fnsz
  82.     character*60 fnam60
  83.     equivalence(fname(1),fnam60)
  84.     common/fn/fnsz,fname
  85.     LOGICAL  got1, got2    
  86. c  flags to signal which date(s) passed in
  87.     character out(80)        
  88. c  output record for appointment file
  89.     character monthn(9)
  90.     INTEGER cowrd1(7,6)    
  91. c  binary array for last month
  92.     INTEGER cowrd2(7,6)    
  93. c  binary array for this month
  94.     INTEGER cowrd3(7,6)    
  95. c  binary array for next month
  96.                 
  97. c  maximum of 6 weeks in a month
  98.  
  99.     do 1 i=1,40        
  100. c  trim off the 'O ' from begining
  101.         line(i) = line(i+2)
  102. 1    continue
  103.  
  104.     got1 = .false.
  105.     got2 = .false.
  106.  
  107.     CALL DATMUN(LINE)    
  108. c  if date(s) was(ere) specified in line, then
  109.     Do 22 i=1,6        
  110. c  extract it (them) from line:
  111.         If ( ( line(i) .gt. '9' ) .or. ( line(i) .lt. '0' ) ) goto 33
  112. 22    Continue
  113.     got1 = .true.        
  114. c  flag existence of 1st date
  115.     temp(1) = line(1)    
  116. c  Six numbers in a row, 
  117.     temp(2) = line(2)    
  118. c  decode into numeric date:
  119.     read(temp2,2)im
  120. c    decode ( 2 , 2 , temp ) im
  121.     temp(1) = line(3)
  122.     temp(2) = line(4)
  123.     read(temp2,2)id
  124. c    decode ( 2 , 2 , temp ) id
  125.     temp(1) = line(5)
  126.     temp(2) = line(6)
  127.     read(temp2,2)iye
  128. c    decode ( 2 , 2 , temp ) iye
  129. 2    Format(i2)
  130.  
  131.     Do 3 i=1,63        
  132. c  Now discard the first date 
  133.         line(i) = line(i+7)    
  134. c  part from line string:
  135. 3    continue
  136.     got2 = .true.        
  137. c  flag existence of second date
  138.     CALL DATMUN(LINE)    
  139. c  if 2nd date was specified in line, then
  140.     Do 23 i=1,6        
  141. c  extract it from line also:
  142.         If ( ( line(i) .gt. '9' ) .or. ( line(i) .lt. '0' ) ) goto 33
  143. 23    Continue
  144.     temp(1) = line(1)    
  145. c  Six numbers in a row, 
  146.     temp(2) = line(2)    
  147. c  so decode into numeric date:
  148.     read(temp2,2)im2
  149. c    decode ( 2 , 2 , temp ) im2
  150.     temp(1) = line(3)
  151.     temp(2) = line(4)
  152.     read(temp2,2)id2
  153. c    decode ( 2 , 2 , temp ) id2
  154.     temp(1) = line(5)
  155.     temp(2) = line(6)
  156.     read(temp2,2)iye2
  157. c    decode ( 2 , 2 , temp ) iye2
  158.  
  159. 33    continue
  160.     If (.not. got1) call idate(im,id,iye)    
  161. c  default start date = today
  162.     If (.not. got2) then            
  163. c  default ending date
  164.         im2 = 12                
  165. c  is dec 31, 1999
  166.         id2 = 31
  167.         iye2 = 99
  168.     end if
  169.  
  170.     open (4,file='DTC.OUT',form='FORMATTED',status='NEW')
  171.     call idate(idis1,idis2,idis3)
  172.     write(4,38) idis1,idis2,idis3
  173. 38    format('1 DTC Rev 22-NOV-83    Appointments Summary',
  174.      1        10x,' Print Date: ',2(i2,'/'),i2,/)
  175.  
  176.     Do 34 i=1,80        
  177. c  start building the output line array
  178.         out(i) = ' '    
  179. c  first fill it with blanks
  180. 34    Continue
  181.  
  182.     If ( im .eq. 1 ) then    
  183. c  get previous month's month name string
  184.         nm = 12        
  185. c  logic here is for year boundaries
  186.         ny = iy - 1
  187.     Else
  188.         nm = im - 1
  189.         ny = iye
  190.     End If
  191.     call gaby(nm,monthn)    
  192. c  got the string, now stick it in output
  193.     j = 0            
  194. c  spacing it every other letter
  195.     Do 4 i=1,17,2
  196.         j = j + 1
  197.         out(i) = monthn(j)
  198. 4    Continue
  199.     call gaby(im,monthn)    
  200. c  now get this month's month name string
  201.     j = 0            
  202. c  and stick it into output string same way
  203.     Do 5 i=1,17,2
  204.         j = j + 1
  205.         out(i+28) = monthn(j)
  206. 5    continue
  207.     ly = iye
  208.     lm = im + 1        
  209. c  Get next month's month name string
  210.     If ( lm .gt. 12 ) then    
  211. c  and stick into output string
  212.         lm = 1
  213.         ly = iye + 1
  214.     End If
  215.     call gaby(lm,monthn)
  216.     Do 61 i=1,9
  217.         j = (i*2)-1
  218.         out(j+55) = monthn(i)
  219. 61    Continue
  220.  
  221.     write(4,6) (out(i),i=1,79)    
  222. c  WRITE MONTH NAME HEADERS
  223. 6    format(1x,79a1)
  224.  
  225.     write(4,69)
  226. 69    format(' Su Mo Tu We Th Fr Sa ',5x,' Su Mo Tu We Th Fr Sa ',
  227.      1        5x,' Su Mo Tu We Th Fr Sa')
  228.  
  229. c    Now do the calendar logic to build the three months' numeric
  230. c    calendar displays and load them into OUT one line at a time
  231. c    Hmmmmmm.... how do we wanna do this?
  232. c
  233. c    I shall take the coward's way out:
  234. c    we shall build three numeric arrays, one for each month 
  235. c    three numeric arrays which contain the dates for last month,
  236. c    this month, and next month in binary, then fill OUT with the
  237. c    ascii rows from each, and print OUT....
  238.  
  239.  
  240. c    lm contains next months month number
  241. c    nm contains last months month number
  242. c    im contains this months month number
  243. c        send these guys into dany...
  244. c    use dany and extract algorithm out of mischy to build these
  245. c    three coward arrays
  246.  
  247.     call dany(ib,il,nm,ny)        
  248. c  get day of week, days in month
  249.                     
  250. c  for last month
  251.     ip = ib - 1            
  252. c  day of week pointer (collumn #)
  253.     iy = 1                
  254. c  row number index into array
  255.     Do 7 i=1,il
  256.         ip = ip + 1            
  257. c  increment day number
  258.         If ( ip .gt. 7 ) then    
  259. c  is it Sunday again?
  260.         ip = 1            
  261. c  reset day to Sunday.
  262.         iy = iy + 1        
  263. c  move down one line
  264.         End If
  265.         cowrd1(ip,iy) = i        
  266. c  stick date into binary array
  267. 7    Continue
  268.  
  269.     call dany(ib,il,lm,ly)        
  270. c  get day of week, days in month
  271.                     
  272. c  for next month
  273.     ip = ib - 1            
  274. c  day of week pointer (collumn #)
  275.     iy = 1                
  276. c  row number index into array
  277.     Do 8 i=1,il
  278.         ip = ip + 1            
  279. c  increment day number
  280.         If ( ip .gt. 7 ) then    
  281. c  is it Sunday again?
  282.         ip = 1            
  283. c  reset day to Sunday.
  284.         iy = iy + 1        
  285. c  move down one line
  286.         End If
  287.         cowrd3(ip,iy) = i        
  288. c  stick date into binary array
  289. 8    Continue
  290.     call dany(ib,il,im,iye)        
  291. c  get day of week, days in month
  292.                     
  293. c  for this month
  294.     ip = ib - 1            
  295. c  day of week pointer (collumn #)
  296.     iy = 1                
  297. c  row number index into array
  298.     Do 9 i=1,il
  299.         ip = ip + 1            
  300. c  increment day number
  301.         If ( ip .gt. 7 ) then    
  302. c  is it Sunday again?
  303.         ip = 1            
  304. c  reset day to Sunday.
  305.         iy = iy + 1        
  306. c  move down one line
  307.         End If
  308.         cowrd2(ip,iy) = i        
  309. c  stick date into binary array
  310. 9    Continue
  311.  
  312. c    Now we have finished building the coward arrays; just
  313. c    stick data from them into OUT, one line at a time and print
  314. c    OUT, and we are through with header section, so:
  315.  
  316.     Do 12 io=1,6
  317.  
  318.         Do 10 i=1,79
  319.         out(i) = 0
  320. 10        continue
  321.  
  322.         j = 1
  323.         Do 11 i=1,7
  324.     write(temp2,2)cowrd1(i,io)
  325. c            encode(2,2,temp) cowrd1(i,io)
  326.         out(j)= temp(1)
  327.         out(j+1) = temp(2)
  328.     write(temp2,2)cowrd2(i,io)
  329. c        encode(2,2,temp) cowrd2(i,io)
  330.             out(j+27) = temp(1)
  331.         out(j+28) = temp(2)
  332.     write(temp2,2)cowrd3(i,io)
  333. c        encode(2,2,temp),cowrd3(i,io)
  334.         out(j+54) = temp(1)
  335.         out(j+55) = temp(2)
  336.         j = j + 3
  337. 11        continue
  338.  
  339.         Do 118 ii=1,80                
  340. c  if values are
  341.             if (out(ii).eq.0) out(ii) = ' '    
  342. c  0, make em blanks
  343.             if ((out(ii).eq.'0').and.        
  344.      1            (out(ii-1).lt.'1'))out(ii)=' '
  345. c  unless we want 0's
  346. 118        continue
  347.  
  348.         write(4,13) (out(i),i=1,79)
  349. 13        FORMAT(1X,79a1)
  350.  
  351. 12    continue
  352.  
  353. c    now read appointments    
  354.  
  355.     open (1,file=fnam60,form='FORMATTED',status='OLD')
  356. C IBM PC MINI COMPILER DOESN'T HAVE ERR= ON OPENS.
  357.     write(4,15)        
  358. c  skip a line past last one on calendars
  359. 15    format(/)
  360.  
  361. 21    continue            
  362. c  now process appointments:
  363.         read(1,722,end=26) iyo,imo,ido,itim,(appoin(i),i=1,60)
  364. 722        format(i2,i2,i2,i3,60a1)
  365.  
  366. c
  367. c    Check to see if appointment is in range:
  368. c    qqq stick range check code here ************** qqq ************
  369. c
  370. c    If .not.((imo.ge.ime).and.(imo.le.im2)) goto 21
  371. c
  372.  
  373.         write(4,723) imo,ido,iyo,itim,(appoin(i),i=1,60)
  374. 723        format(1x,i2,'/',i2,'/',i2,2x,i3,'0',' - ',60a1)
  375.  
  376.         goto 21
  377.  
  378. 26    continue
  379.  
  380. 990    return
  381.     end
  382.  
  383.  
  384.