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 / month.for < prev    next >
Text File  |  1995-05-19  |  6KB  |  309 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c-----------------------------------------------------------------------
  4. c
  5. c    Month-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: M [dd[19[yy]]]
  11. c
  12. c    Output:
  13. c        display screen (see below)
  14. c
  15. c-----------------------------------------------------------------------
  16. c
  17.  
  18.     SUBROUTINE month(line)
  19.  
  20. c
  21. c    Declarations:
  22. c
  23.  
  24.     character line(1)        
  25. c     input line
  26.     CHARACTER*2 TEMP2
  27.     character temp(2)
  28.     EQUIVALENCE(TEMP(1),TEMP2)
  29. C    
  30. c     temporary string converting array
  31.     character esc        
  32. c     escape character
  33.     integer    id        
  34. c     Julian Day
  35.     integer im        
  36. c     Julian Month
  37.     integer iy        
  38. c     Julian Year
  39.     character monthn(9)        
  40. c     string month name
  41.     character out(79)        
  42. c     The output string and * array
  43.     character appoin(60)        
  44.     CHARACTER*20 APPOI6
  45.     EQUIVALENCE(APPOIN(1),APPOI6)
  46. c     Appointment string
  47.         character rchr
  48.     integer rdspfg          
  49. c   flag to reverse sense of display of time
  50.     integer ctlfg           
  51. c   misc control flags here
  52.     INTEGER IDYR,IDMO,IDDY
  53.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  54.     common/ctls/rdspfg,ctlfg
  55.     character fname(60)
  56.     CHARACTER*60 FNAM60
  57.     EQUIVALENCE(FNAME(1),FNAM60)
  58.     integer fnsz
  59.     common/fn/fnsz,fname
  60.  
  61. c
  62. c    Initialize:
  63. c
  64.  
  65.     iterm = 0        
  66. c     Output terminal unit number
  67.     esc = 27        
  68. c     Escape character
  69.     IM=IDMO
  70.     ID=IDDY
  71.     IY=IDYR
  72. C    call idate(im,id,iy)    
  73. c     initialize to today's date
  74.  
  75.  
  76. c
  77. c        Trim off the M from command line:
  78. c
  79.  
  80.     Do 1 i=1,70
  81.         line(i) = line(i+2)
  82. 1    Continue
  83.     CALL DATMUN(LINE)
  84. c
  85. c        If the month was specified in command line then
  86. c        set im and iy to the right values:
  87. c
  88.  
  89.     If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
  90.         temp(1) = line(1)
  91.         temp(2) = line(2)
  92.     read(temp2,2)im
  93. c        decode ( 2 , 2 , temp ) im
  94.     IDMO=IM
  95.     End If
  96.     If ( ( line(3) .ge. '0' ) .and. ( line(4) .le. '9' ) ) then
  97.         temp(1) = line(3)
  98.         temp(2) = line(4)
  99.     read(temp2,2)iy
  100. c        decode ( 2 , 2 , temp ) iy
  101.     IDYR=IY
  102.     End If
  103. 2    Format(i2)
  104.  
  105. c
  106. c        Clear the screen, move the cursor to the top part,
  107. c
  108.  
  109.     write(iterm,6) esc,'<',esc,'[','2','J',esc,'[','0','1',';','0',
  110.      1  '1','H'
  111.  
  112. c
  113. c        Now start building the output string: (out)
  114. c
  115.  
  116.     Do 3 i=1,79
  117.         out(i) = ' '
  118. 3    Continue
  119.  
  120.     If ( im .eq. 1 ) then
  121.         nm = 12
  122.         ny = iy - 1
  123.     Else
  124.         nm = im - 1
  125.         ny = iy
  126.     End If
  127. C PRINT PREVIOUS MONTH
  128.     call gaby(nm,monthn)
  129.  
  130.     j = 0
  131.     Do 4 i=1,17,2
  132.         j = j + 1
  133.         out(i) = monthn(j)
  134. 4    Continue
  135.  
  136.     out(37) = '1'
  137.     out(39) = '9'
  138.     write(temp2,2)iy
  139. c    encode( 2 , 2 , temp ) iy
  140.     out(41) = temp(1)
  141.     out(43) = temp(2)
  142.  
  143.     lm = im + 1
  144.     If ( lm .gt. 12 ) then
  145.         lm = 1
  146.         ly = iy + 1
  147.     End If
  148. C PRINT NEXT MONTH CALENDAR AT TOP
  149.     call gaby(lm,monthn)
  150.  
  151.     Do 5 i=1,9
  152.         j = (i*2)-1
  153.         out(j+62) = monthn(i)
  154. 5    Continue
  155. C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS
  156.     write(iterm,6) out
  157. 6    format(1x,79a1,\)
  158.     write(iterm,7)
  159. 7    format(1x,'Su Mo Tu We Th Fr Sa',40X,'Su Mo Tu We Th Fr Sa')
  160.  
  161. c
  162. c    Now display last month, header for this month, and next month:
  163. c
  164.  
  165.     If ( im .eq. 1 ) then
  166.         lm = 12
  167.         ly = iy - 1
  168.     Else
  169.         lm = im - 1
  170.         ly = iy
  171.     End If
  172.  
  173.     If ( im .eq. 12) then
  174.         nm = 1
  175.         ny = iy + 1
  176.     Else
  177.         nm = im + 1
  178.         ny = iy
  179.     End If
  180.  
  181.     call dany(ib,il,lm,ly)
  182.     call mischy(ib,il,0,0,0,0)
  183.     call dany(ib,il,nm,ny)
  184. C CHANGE ,69, NEXT TO ,59, ...
  185.     call mischy(ib,il,59,0,0,0)
  186.  
  187. c
  188. c        dislpay big banner header name of this month:
  189. c
  190.  
  191.     call dtcat(37,7)
  192.     call gaby(im,monthn)
  193.         write(iterm,8) monthn
  194. 8        format(1X,9a1)
  195. 9    Continue
  196.  
  197. c
  198. c    Now print the week day headers for this month, and the days
  199. c    for this month:
  200. c
  201.  
  202. C    call dtcat(1,9)
  203.     call dtcat(1,8)
  204.     write(iterm,10)
  205. 10    format(/,8x,'SUNDAY',3X,'MONDAY',3X,'TUESDAY',2X,'WEDNESDAY',2X,
  206.      1  'THURSDAY',3X,'FRIDAY',5X,'SATURDAY',/)
  207.  
  208.     call dany(ib,il,im,iy)
  209.     call mischy(ib,il,1,7,8,1)
  210.  
  211. c
  212. c        Now for files I/O to put *'s on days with appointments:
  213. c
  214.  
  215.     Do 110 i=1,31        
  216. c  set the out array to all blanks:
  217.      if(rdspfg.eq.0)then
  218.         out(i) = ' '
  219.      else
  220.         out(i)='*'
  221.      end if
  222.     if(rdspfg.eq.0)then
  223.         rchr='*'
  224.     else
  225.         rchr=' '
  226.     end if
  227. 110    continue
  228. C CLOSE UNIT 1, JUST IN CASE IT WAS OPEN...
  229.     CLOSE(1)
  230.     Open (1,file=FNAM60,status='OLD',form='FORMATTED')
  231.     iunit=1
  232. 111    Continue    
  233. c  ===================================================
  234.         Read(IUNIT,115,end=122) ihy,ihm,ihd,iht,(appoin(k),k=1,60)    
  235. c 
  236. 115        format(3i2,i3,60a1)                        
  237. c 
  238. c single indirection if year = 99
  239. c this permits use of multiple data files for scheduling purposes
  240. c maintained by an editor. Note the format is
  241. c999999999filename=
  242. c where
  243. c filename may be absolutely any file spec whatever...
  244.     if(IUNIT.EQ.1.AND.ihy.eq.99)then
  245.     iunit=2
  246. c null terminate the filename somewhere
  247. c lines with 99 in 1st 2 cols are filenames only...
  248. c use = as delimiter of filename
  249.     appoin(60)=32
  250.     kkk=0
  251.     do 1068 ii=1,59
  252.     if(appoin(ii).le.32.or.appoin(ii).eq.'=')kkk=1
  253.     if(kkk.gt.0)appoin(ii)=32
  254. c    if(appoin(ii).eq.'=')appoin(ii)=0
  255. 1068    continue
  256.     Open(iunit,file=appoi6,status='old',form='formatted')
  257.     goto 111
  258.     end if
  259.                                     
  260. c 
  261.         If (( ihm .eq. im ) .and. ( ihy .eq. iy )) out(ihd) = rchr  
  262. c 
  263.         goto 111                            
  264. c 
  265. 122    Continue    
  266. c ====================================================
  267.     if(iunit.ne.1)then
  268. 1066    close(2)
  269.     iunit=1
  270.     goto 111
  271.     end if
  272.  
  273.     call idate(irm,ird,iry)                
  274. c  Real month,day,year
  275.     If ((irm.eq.im).and.(iry.eq.iy)) out(ird)='#'    
  276. c  put # character on.
  277.  
  278.     close(1)
  279.     iy = 12
  280. C WAS IY=13
  281.     ip = ib - 1
  282.     
  283.     Do 1115 i=1,il
  284.  
  285.         ip = ip + 1            
  286. c     increment day number
  287.         If ( ip .gt. 7 ) then    
  288. c     is it Sunday again?
  289.         ip = 1            
  290. c     reset day to Sunday.
  291.         iy = iy + 2         
  292. c     move down one line
  293.         End If
  294.         ix = 10 * ip - 2
  295.         call dtcat(ix,iy)        
  296. c     position cursor
  297.         write(iterm,231) out(i)    
  298. c     write * to screen
  299. 231        format(1X,a1)
  300.  
  301. 1115    Continue
  302.     
  303.     call dtcat(1,23)
  304.  
  305.     return
  306.     end
  307.  
  308.  
  309.