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 / strip.for < prev    next >
Text File  |  1995-05-19  |  3KB  |  153 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c-----------------------------------------------------------------------
  4. c
  5. c    Strip Daily Appointment subroutine
  6. c
  7. c    part of GLENN EVERHART'S MODS TO DTC program
  8. c
  9. c    Input: 
  10. c       line - 72 characters;  Format: P [mmddyy]
  11. c
  12. c    Output:
  13. c        Strips old appointments (before date) from dtc.dat
  14. c    and builds new dtc.dat.
  15. c
  16. c-----------------------------------------------------------------------
  17. c
  18.  
  19.     SUBROUTINE strip(line)
  20.  
  21. c
  22. c    Declarations:
  23. c
  24.  
  25.     character line(1)        
  26. c     input line
  27.     CHARACTER*2 TMP2
  28.     character temp(2)        
  29.     EQUIVALENCE(TMP2,TEMP(1))
  30. c     temporary string converting array
  31.     character appoin(60)        
  32. c     appointment string
  33.     character esc        
  34. c     escape character
  35.     integer    id        
  36. c     Julian Day
  37.     integer im        
  38. c     Julian Month
  39.     integer iye        
  40. c     Julian Year
  41.     integer rdspfg          
  42. c   flag to reverse sense of display of time
  43.     integer ctlfg           
  44. c   misc control flags here
  45.     common/ctls/rdspfg,ctlfg
  46.     character fname(60)
  47.     CHARACTER*20 FNAM60
  48.     EQUIVALENCE (FNAME(1),FNAM60)
  49.     integer fnsz
  50.     common/fn/fnsz,fname
  51.  
  52. c
  53. c    Initialize:
  54. c
  55.  
  56.     iterm = 0        
  57. c     Output terminal unit number
  58.     esc = 27        
  59. c     Escape character
  60.     call idate(im,id,iye)    
  61. c     initialize to today's date
  62.  
  63.  
  64. c
  65. c        Parse that line
  66. c 
  67. c
  68.  
  69. c
  70. c        Was there a P on the front?  If so, trim it off:
  71. c
  72.  
  73.     IDMX=0
  74.     If ( line(1) .eq. 'P' .or.line(1).eq.'p') then
  75.         Do 1 i=1,70
  76.         line(i) = line(i+2)
  77. 1        Continue
  78.  
  79.     End If
  80.  
  81.  
  82. c
  83. c        If the date was specified in command line then
  84. c        set id, im and iye to the right values:
  85. c
  86.     CALL DATMUN(LINE)
  87.     Do 22 i=1,6
  88.         IDL=I
  89.         If ( ( line(i) .gt. '9' ) .or. ( line(i) .lt. '0' ) ) goto 33
  90. 22    Continue
  91.  
  92. c    Six numbers in a row, so decode into numeric date:
  93.  
  94.         temp(1) = line(1)
  95.         temp(2) = line(2)
  96.     read(tmp2,2)im
  97. c        decode ( 2 , 2 , temp ) im
  98.         temp(1) = line(3)
  99.         temp(2) = line(4)
  100.     read(tmp2,2)id
  101. c        decode ( 2 , 2 , temp ) id
  102.         temp(1) = line(5)
  103.         temp(2) = line(6)
  104.     read(tmp2,2)iye
  105. c        decode ( 2 , 2 , temp ) iye
  106. 2    Format(i2)
  107.  
  108. c
  109. c        Now discard the date part from line string:
  110. c
  111.  
  112.         Do 3 i=1,63
  113.         line(i) = line(i+7)
  114. 3        continue
  115.     GOTO 3307
  116. 33    continue
  117. C GOT A DELIMITER NOT A NUMERIC IN 1ST 6 COLS SO MAKE THAT THE START OF LINE
  118. C BY CHOPPING OFF ALL THAT'S EARLIER
  119.     IF(IDL.LE.0.OR.IDL.GT.6)GOTO 3307
  120.     DO 3308 I=1,63
  121.         LINE(I)=LINE(I+IDL)
  122. 3308    CONTINUE
  123. 3307    CONTINUE
  124.     KHSH=ID+32*(IM+12*(IYE-81))
  125. C ADD CLOSE TO GUARANTEE NO FAILURES...
  126.                 CLOSE(1)
  127.     Open (1, file=FNAM60,status='OLD',form='FORMATTED')
  128.         close(2)
  129.     OPEN(2,FILE=FNAM60,STATUS='NEW',FORM='FORMATTED')
  130.  
  131. 100    continue    
  132. c     loop back up here to continue reading and
  133.             
  134. c     processing input file:
  135.  
  136.  
  137.     read(1,200,end=400) ihy,ihm,ihd,iht,(line(k),k=1,60)
  138. 200    format(3i2,i3,60a1)
  139.     LHSH=IHD+32*(IHM+12*(IHY-81))
  140.     IF(LHSH.LT.KHSH)GOTO 100
  141.     WRITE(2,200)IHY,IHM,IHD,IHT,(LINE(K),K=1,60)
  142.     goto 100
  143.  
  144. 400    continue    
  145. c  no more appointments left in file.
  146.     close(1)
  147.     CLOSE(2)
  148.  
  149.     return
  150.     end
  151.  
  152.  
  153.