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 / day.for < prev    next >
Text File  |  1995-05-19  |  9KB  |  401 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3. c-----------------------------------------------------------------------
  4. c
  5. c    Daily Appointment subroutine
  6. c
  7. c    part of Mitch Wyle's DTC program
  8. c
  9. c    Input: 
  10. c       line - 72 characters;  Format: D [mmddyy [hh:mm>HH:MM [appointment]]]
  11. c
  12. c    Output:
  13. c        display screen (see below)
  14. c
  15. c-----------------------------------------------------------------------
  16. c
  17.  
  18.     SUBROUTINE day(line2)
  19.  
  20. c
  21. c    Declarations:
  22. c
  23.     CHARACTER LINE2(80)
  24.     character line(80)        
  25.     CHARACTER*18 LINE16
  26.     EQUIVALENCE(LINE(1),LINE16)
  27. c     input line
  28.     CHARACTER*2 TEMP2
  29.     character temp(2)        
  30.     EQUIVALENCE(TEMP(1),TEMP2)
  31. c     temporary string converting array
  32.     character appoin(60)        
  33. c     appointment string
  34.     character work(60)           
  35. c   scratch array for handling scheduling
  36.     character esc        
  37. c     escape character
  38.     integer    id        
  39. c     Julian Day
  40.     integer im        
  41. c     Julian Month
  42.     integer iye        
  43. c     Julian Year
  44.     integer rdspfg          
  45. c   flag to reverse sense of display of time
  46.     character junk(130)
  47.     integer ctlfg           
  48. c   misc control flags here
  49.     INTEGER IDYR,IDMO,IDDY
  50.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  51.     common/ctls/rdspfg,ctlfg
  52.     character fname(60)
  53.     CHARACTER*18 FNAM60
  54.     EQUIVALENCE(FNAME(1),FNAM60)
  55.     integer fnsz
  56.     common/fn/fnsz,fname
  57.  
  58. c
  59. c    Initialize:
  60. c
  61.     DO 933 IV=1,80
  62. 933    LINE(IV)=LINE2(IV)
  63.     iterm = 0        
  64. c     Output terminal unit number
  65.     esc = 27        
  66. c     Escape character
  67. C    call idate(im,id,iye)    
  68. c     initialize to today's date
  69.     IM=IDMO
  70.     ID=IDDY
  71.     IYE=IDYR
  72.  
  73. c
  74. c        Parse that line
  75. c 
  76. c
  77. c        Was there a D on the front?  If so, trim it off:
  78. c
  79.  
  80.     IDMX=0
  81.     If ( line(1) .eq. 'D' .or.line(1).eq.'d') then
  82.         Do 1 i=1,70
  83.         line(i) = line(i+2)
  84. 1        Continue
  85.  
  86.     End If
  87.  
  88.  
  89. c
  90. c        If the date was specified in command line then
  91. c        set id, im and iye to the right values:
  92. c
  93.  
  94.     CALL DATMUN(LINE)
  95.     Do 22 i=1,6
  96.         IDL=I
  97.         If ( ( line(i) .gt. '9' ) .or. ( line(i) .lt. '0' ) ) goto 33
  98. 22    Continue
  99.  
  100. c    Six numbers in a row, so decode into numeric date:
  101.  
  102.         temp(1) = line(1)
  103.         temp(2) = line(2)
  104.     read(temp2,2)im
  105. c        decode ( 2 , 2 , temp ) im
  106.         temp(1) = line(3)
  107.         temp(2) = line(4)
  108. c        decode ( 2 , 2 , temp ) id
  109.     read(temp2,2)id
  110.         temp(1) = line(5)
  111.         temp(2) = line(6)
  112. c        decode ( 2 , 2 , temp ) iye
  113.     read(temp2,2)iye
  114.     IDDY=ID
  115.     IDYR=IYE
  116.     IDMO=IM
  117. 2    Format(i2)
  118.  
  119. c
  120. c        Now discard the date part from line string:
  121. c
  122.  
  123.         Do 3 i=1,63
  124.         line(i) = line(i+7)
  125. 3        continue
  126.     GOTO 3307
  127. 33    continue
  128. C GOT A DELIMITER NOT A NUMERIC IN 1ST 6 COLS SO MAKE THAT THE START OF LINE
  129. C BY CHOPPING OFF ALL THAT'S EARLIER
  130.     IF(IDL.LE.0.OR.IDL.GT.6)GOTO 3307
  131.     DO 3308 I=1,63
  132.         LINE(I)=LINE(I+IDL)
  133. 3308    CONTINUE
  134. 3307    CONTINUE
  135. c
  136. c        Clear the screen, move the cursor to the top part,
  137. c        set up appointments screen:
  138. c
  139.  
  140.     write(iterm,4) esc,'[','2','J',esc,'[','0','1',';','0',
  141.      1  '1','H'
  142. 4    format(1X,79a1)
  143.  
  144.     write(iterm,5) im,id,iye
  145. 5    format(1X,10X,'Appointments For ',i2,'/',i2,'/',i2,/)
  146.  
  147.     Do 8 i=8,16
  148.         If ( i .gt. 12 ) then
  149.         j = i - 12
  150.         Else
  151.         j = i
  152.         End If
  153.         write(iterm,6) j
  154. 6        format(1x,i2,':00   -')
  155.         write(iterm,7) j
  156. 7        format(1x,i2,':30   -')
  157. 8    Continue
  158.  
  159.     write(iterm,9)
  160. 9    format(1x,'Evening:',/,79('='))
  161.  
  162. c
  163. c    Was a time input?  Did it accompany an appointment string?
  164. c    Why do fools fall in love?
  165. c
  166.     IDMX=0
  167.     if(line(1).eq.'e')LINE(1)='E'
  168.     If (((line(1).le.'9').and.(line(1).ge.'0')).OR.LINE(1)
  169.      1   .EQ.'E') then
  170.  
  171. c
  172. c        Parse the time string
  173. c
  174.       IF(LINE(1).NE.'E') THEN
  175.  
  176.         If ( line(2) .eq. ':' ) then
  177.         temp(1) = '0'
  178.         temp(2) = line(1)
  179.     READ(TEMP2,2)IHT
  180. C        decode ( 2 , 2 , temp2 ) iht
  181.         if ( iht .lt. 5 ) iht = iht + 12
  182.         IHHR=IHT
  183.         iht = iht * 10
  184.         If ( line(3) .eq. '3' ) iht = iht + 3
  185.         Else If ( line(3) .eq. ':' ) then
  186.         temp(1) = line(1)
  187.         temp(2) = line(2)
  188.       READ(TEMP2,2)IHT
  189. C        decode ( 2 , 2 , temp2 ) iht
  190.         If ( iht .lt. 5 ) iht = iht + 12
  191.         IHHR=IHT
  192.         iht = iht * 10
  193.         If ( line(4) .eq. '3' ) iht = iht + 3
  194.         End If
  195.       END IF
  196. C HANDLE "EV" MODIFIER FOR EVENING APPOINTMENTS
  197.     IF(LINE(1).EQ.'E')IHT=170
  198. C 170 IS SPECIAL EVENING CODE..... CORRESPONDS TO 5PM...
  199.     IHMX=1
  200.     IDHR=0
  201.     IOMX=6
  202.     IF (LINE(6).EQ.'>') THEN
  203. C IF 2 RANGES EXIST DUPLICATE MESSAGE AFTER EXTRACTING 2ND RANGE
  204. C OF HH:MM
  205.     temp(1)=line(7)
  206.     temp(2)=line(8)
  207.     READ(temp2,2)ihmx
  208. c        DECODE(2,2,LINE(7))IHMX
  209.         IF(IHMX.LT.5)IHMX=IHMX+12
  210. c        DECODE(2,2,LINE(10))IMMX
  211.     temp(1)=line(10)
  212.     temp(2)=line(11)
  213.     READ(temp2,2)immx
  214.         IF(IMMX.NE.30)IMMX=0
  215. C COUNT HALF HOURS IN GIVEN INTERVAL ...
  216.         IDHR=(IHMX-IHHR)*2
  217. C FIND NUMBER ENTRIES TO SHOVE OUT...
  218.         IF(IMMX.NE.0)IDHR=IDHR+1
  219.         IF(IHT.NE.(10*IHHR))IDHR=IDHR-1
  220.         IDHR=MAX0(1,IDHR)
  221.         IDMX=IDHR
  222. C ABOVE CLAMPS POSITIVE... NO INVALID ENTRIES PLEASE...
  223.         IOMX=12
  224.     END IF
  225. c
  226. c        Now look for space delimiter to trim off the time
  227. c        of day part, and then extract the appointment:
  228. c
  229.  
  230. C USE IOMX SO WE SCAN PAST 2ND RANGE IF ANY...
  231.         Do 11 io=1,IOMX
  232.         If ( line(1) .eq. ' ') goto 12    
  233. c  Found a space; exit loop
  234.         Do 10 i=1,71
  235.             line(i) = line(i+1)
  236. 10        Continue
  237. 11        Continue
  238. 12        Continue                
  239. c  Label to Exit loop
  240.  
  241. c
  242. c        Was there an appointment string input?
  243. c        If so, put it in file, and display it on screen.
  244. c        If not, move cursor to correct time on screen,
  245. c        then input the appointment, put in file and re-display it.
  246. c
  247.         If ( line(1) .lt. ' ' ) then
  248.         itemp = iht / 10
  249.         if ( itemp .gt. 7 ) itemp = itemp - 7
  250.         iy = 2 * itemp + 1
  251.         If ( ( ( iht/10 ) * 10 ) .ne. iht ) iy = iy + 1
  252.         ix = 10
  253.         call dtcat(ix,iy)
  254. c        close(iterm)
  255. C ... SLIGHTLY SCREWY CODE HERE...
  256.     write(0,1955)
  257. 1955    format('+ Enter appt here:')
  258.         read(0,913,END=914) (line(i),i=1,60)
  259. 913        format(1X,60a1)
  260. 13        format('+',60a1)
  261. 914        CONTINUE
  262.         End If
  263. c copy appointment for use later...
  264.     Do 1118 ivx=1,60
  265. 1118    work(ivx)=line(ivx)
  266.     iwy=iye
  267.     iwm=im
  268.     iwd=id
  269.     iwht=iht
  270.         If ( line(1) .ge. ' ' ) then
  271. C ADD CLOSE TO GUARANTEE NO FAILURES...
  272.                 CLOSE(1)
  273. C  If we are using the 'S' command, ONLY add meetings to the indirected
  274. C  files, not to the current (control) file.
  275.     IF(CTLFG.NE.1) THEN
  276.         Open ( 1,file=FNAM60,status='OLD',form='FORMATTED')
  277.     do 8877 iv=1,9999
  278. c simulate append access by reading to eof
  279.     read(1,8879,end=8878,err=8878)junk
  280. 8879    format(130a1)
  281. 8877    continue
  282. 8878    continue
  283.     backspace 1
  284.     BACKSPACE 1
  285.         IHTSV=IHT
  286.         IF(IDMX.LT.1)IDMX=1
  287.         DO 3005 IVX=1,IDMX
  288.         write(1,614) iye,im,id,iht,(line(i),i=1,60)
  289.         IF((IHT/10)*10.EQ.IHT)THEN
  290. 614        format(3i2,i3,60a1)
  291. C THIS IS AN EVEN HOUR ... ADD THE HALF HOUR
  292.             IHT=IHT+3
  293.         ELSE
  294. C IHT IS A HALF HOUR ... MAKE UP TO NEXT HOUR
  295.             IHT=IHT+7
  296.         END IF
  297. 3005        CONTINUE
  298.         IHT=IHTSV
  299. 14        format(3i2,i3,60a1,\)
  300.     write(1,1600)
  301. 1600    format(/)
  302.         close(1)
  303.     END IF
  304.         End If
  305.     End If
  306.  
  307.     nunit=1
  308.     Open (nunit,file=FNAM60,status='OLD' ,form='FORMATTED')
  309.  
  310. 100    continue    
  311. c     loop back up here to continue reading and
  312.             
  313. c     processing input file:
  314.  
  315.  
  316.     read(nunit,200,end=400) ihy,ihm,ihd,iht,(line(k),k=1,60)
  317. 200    format(3i2,i3,60a1)
  318.     if(ihy.eq.99.and.nunit.eq.1)then
  319.     nunit=2
  320. c null terminate the filename somewhere
  321. c lines with 99 in 1st 2 cols are filenames only...
  322. c use = as delimiter of filename
  323.     line(60)=32
  324.     kkk=0
  325.     do 1068 ii=1,59
  326.     if(line(ii).le.31.or.line(ii).eq.'=')kkk=1
  327.     if(kkk.gt.0)line(ii)=32
  328. c    if(line(ii).eq.'=')line(ii)=32
  329. 1068    continue
  330. C SKIP WRITING IN SUBSIDIARY FILES IF NOT APPORPRIATE FOR COMMAND...
  331.     if(CTLFG.eq.0) goto 1119
  332. c ****
  333. c on scheduling multiple dates via the S function, use this occasion to
  334. c add the record to everyone's calendar file.
  335.                 CLOSE(2)
  336.         Open ( 2,file=line16,status='OLD',form='FORMATTED')
  337.     do 8977 iv=1,9999
  338. c simulate append access by reading to eof
  339.     read(2,8979,end=8978,err=8978)junk
  340. 8979    format(130a1)
  341. 8977    continue
  342. 8978    continue
  343.     backspace 2
  344.     backspace 2
  345.         IHTSV=IHT
  346.         iht=iwht
  347.         IF(IDMX.LT.1)IDMX=1
  348.         DO 3007 IVX=1,IDMX
  349.         write(2,614) iwy,iwm,iwd,iht,(work(i),i=1,60)
  350.         IF((IHT/10)*10.EQ.IHT)THEN
  351. C IF THIS IS AN EVEN HOUR ... ADD THE HALF HOUR
  352.             IHT=IHT+3
  353.         ELSE
  354. C IF THIS IS A HALF HOUR ... MAKE UP TO NEXT HOUR
  355.             IHT=IHT+7
  356.         END IF
  357. 3007        CONTINUE
  358.         IHT=IHTSV
  359.     write(2,1600)
  360.        close(2)
  361. c ****
  362. 1119    continue
  363.     CLOSE(NUNIT)
  364. c7663    continue
  365.     DO 7660 II=1,40
  366. 7660    IF(LINE(II).LE.' ')LINE(II)=' '
  367.     IF(LINE(1).EQ.' ')THEN
  368.      DO 7661 II=1,40
  369. 7661     LINE(II)=LINE(II+1)
  370. c    goto 7663
  371.     END IF
  372.     Open(nunit,file=line16,status='old',form='formatted')
  373.     goto 100
  374.     end if
  375.     If ((iye .eq. ihy) .and. (im .eq. ihm) .and. (id .eq. ihd)) then
  376.         itemp = iht / 10
  377.         if ( itemp .gt. 7 ) itemp = itemp - 7
  378.         iy = 2 * itemp + 1
  379.         If (((iht/10)*10) .ne. iht)    iy = iy + 1
  380.         ix = 10
  381.         call dtcat(ix,iy)
  382.         write(iterm,300) (line(k),k=1,60)
  383. 300        format(1X,60a1,\)
  384.         call dtcat(1,22)
  385.     End If
  386.     goto 100
  387.  
  388. 400    continue    
  389. c  no more appointments left in file.
  390.     if(nunit.ne.1)then
  391. 1067    continue
  392.     close(2)
  393.     nunit=1
  394.     goto 100
  395.     end if
  396.     close(1)
  397.     return
  398.     end
  399.  
  400.  
  401.