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 / year.for < prev   
Text File  |  1995-05-19  |  4KB  |  192 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c-----------------------------------------------------------------------
  4. c
  5. c    Year-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: Y [yy]
  11. c
  12. c    Output:
  13. c        display screen (see below)
  14. c
  15. c-----------------------------------------------------------------------
  16. c
  17.  
  18.     SUBROUTINE year(line)
  19.  
  20. c
  21. c    Declarations:
  22. c
  23.  
  24.     character line(84)        
  25. c     input line
  26.     character temp(2)        
  27.     character*2 temp2
  28.     equivalence(temp(1),temp2)
  29. c     temporary string converting array
  30.     character esc        
  31. c     escape character
  32.     integer    id        
  33. c     Julian Day
  34.     integer im        
  35. c     Julian Month
  36.     integer iye        
  37. c     Julian Year
  38.     integer iyo        
  39. c     y offset for where to put month data
  40.     integer    ix        
  41. c     x coord of cursor
  42.     integer iy        
  43. c     y coord of cursor
  44.     integer    img        
  45. c     month loop index goes from 1 to 12
  46.     integer    jg        
  47. c     index offset defined by img
  48.     integer ii        
  49. c     implied do loop index variable
  50.     INTEGER IDYR,IDMO,IDDY
  51.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  52.     character monthn(9)        
  53. c     string month name
  54.     real badf77        
  55. c     Maybe error in array subscripts
  56.     character wknam(21)        
  57. c     string containing names of days of week
  58.     real badftn        
  59. c     Hoolay kan
  60.     character ihold        
  61. c     hold the screen
  62. c
  63. c    Initialize:
  64. c
  65.  
  66.     Do 121 ii=1,21
  67.         wknam(ii) = ' '
  68. 121    continue
  69.     wknam(1) = 'S'
  70.     wknam(2) = 'u'
  71.     wknam(4) = 'M'
  72.     wknam(5) = 'o'
  73.     wknam(7) = 'T'
  74.     wknam(8) = 'u'
  75.     wknam(10)= 'W'
  76.     wknam(11)= 'e'
  77.     wknam(13)= 'T'
  78.     wknam(14)= 'h'
  79.     wknam(16)= 'F'
  80.     wknam(17)= 'r'
  81.     wknam(19)= 'S'
  82.     wknam(20)= 'a'
  83.     wknam(21)= '|'
  84.  
  85.     iterm = 0        
  86. c     Output terminal unit number
  87.     esc = 27        
  88. c     Escape character
  89.     IM=IDMO
  90.     ID=IDDY
  91.     IYE=IDYR
  92. C    call idate(im,id,iye)    
  93. c     initialize to today's date
  94.  
  95.     If (line(1) .eq. 'Y') then
  96.         Do 1 i=1,70            
  97. c     Trim of the 'Y' from the
  98.         line(i) = line(i+2)    
  99. c     command line
  100. 1        Continue
  101.     End If
  102.  
  103.     If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
  104.         temp(1) = line(1)
  105.         temp(2) = line(2)
  106.     read(temp2,2)iye
  107. c        decode ( 2 , 2 , temp ) iye
  108.     IDYR=IYE
  109.     End If
  110. 2    Format(i2)
  111.     Temp(1)=32
  112.     Temp(2)=32
  113.     write(iterm,3) esc,'<',esc,'[','2','J'    
  114. c  Clear screen invoke ANSI
  115.     write(iterm,3) esc,'[','?','3','h'    
  116. c  set screen to 132 col
  117.     write(temp2,2)iye
  118. c    encode ( 2 , 2 , temp ) iye
  119.     ix = 30
  120.     iy = 11
  121.     call dtcat(ix,iy)            
  122. c  Display this year in double
  123.     write(iterm,3) '1', 
  124.      1  ' ','9',' ',temp(1),' ',temp(2) 
  125. c  in the middle of the screen
  126.     iy = 12
  127.     call dtcat(ix,iy)
  128. c    write(iterm,3) esc,'#','4','1',
  129. c     1  ' ','9',' ',temp(1),' ',temp(2) 
  130. c  double size
  131.  
  132.     Do 4 img = 1,12            
  133. c     for each month:
  134.         call gaby(img,monthn)    
  135. c     Find out name, and display it
  136.         jg = img - 1        
  137. c     x coord of cursor for month
  138.         if (jg .gt. 5) jg = jg - 6  
  139. c     name in outstring
  140.         ix = ( jg * 22 ) + 1    
  141. c 
  142.         if (img .gt. 6) then    
  143. c     First six months on top
  144.         iy = 13            
  145. c     last six months on bottom
  146.         else            
  147. c     half of screen
  148.         iy = 2
  149.         end if
  150.         call dtcat(ix,iy)        
  151. c     Position cursor and:
  152.         write(iterm,3) (monthn(ii),ii=1,9)
  153. 3        format(1x,21a1,\)
  154. c     Write out the name.
  155.         If (img .gt. 6) then    
  156. c     Write out day of week
  157.         iy = 14            
  158. c     Header names also, one
  159.         else            
  160. c     line below month names
  161.         iy = 3
  162.         end if
  163.         call dtcat(ix,iy)
  164.         write(iterm,3) (wknam(ii),ii=1,21)
  165.  
  166.         If (img .gt. 6) then    
  167. c     Write out numbers for
  168.         iy = 15            
  169. c     Days in each month:
  170.         iyo = 12
  171.         else
  172.         iy = 4
  173.         iyo = 1
  174.         end if
  175.         call dany(ib,il,img,iye)    
  176. c     Now position the month
  177.         ix = ix - 1            
  178. c     Off by 1.  CORRECT IT
  179.         ixspa = 0
  180.         ixo   = 0
  181.         iyspa = 0
  182.         call mischy(ib,il,ix,ixspa,iyo,iyspa)
  183. 4    Continue
  184. c return next line read in and allow main pgm to decode...
  185.     read(0,80,END=914)line
  186. 80    format(84a1)
  187. 914    write(0,3) esc,'[','?','3','l'
  188.     return
  189.     end
  190.  
  191.  
  192.