home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Interactive Reference Guide / C-C++ Interactive Reference Guide.iso / c_ref / csource5 / 349_01 / sss.arc / EX_0506.FOR < prev    next >
Encoding:
Text File  |  1991-04-10  |  5.3 KB  |  199 lines
  1. C     Program EX_0506.FOR
  2. C     Listing 11F - see documentation in TUTOR.SSS
  3.  
  4. $include:'SSSF1.H'
  5.  
  6.       subroutine prime
  7. $include:'SSSF2.H'
  8.       integer ARRIVL, STARTA, ENDACT, NEXTAC, FINAL
  9.       integer ecode, statn, rewkn
  10.       logical debugf, busy, block
  11.       real*8  defect, serial
  12.       common  ARRIVL, STARTA, ENDACT, NEXTAC, FINAL,
  13.      +  ecode, statn, rewkn, debugf, busy(3), block(3),
  14.      +  defect(3), serial
  15.  
  16.       ARRIVL = 1
  17.       STARTA = 2
  18.       ENDACT = 3
  19.       NEXTAC = 4
  20.       FINAL  = 3
  21.  
  22.       debugf = .FALSE.
  23.       serial = 1.0
  24.       do 1 i=1, 3
  25.       busy(i)  = .FALSE.
  26.   1   block(i) = .FALSE.
  27.       defect(1) = 0.3
  28.       defect(2) = 0.2
  29.       defect(3) = 0.1
  30.  
  31.       call INIQUE(3, 2, 3)
  32.       call inista(1,'Prodt#1          ', 0, 0, 0.0, 0.0)
  33.       call inista(2,'Prodt#2          ', 0, 0, 0.0, 0.0)
  34.       call inista(3,'Prodt#3          ', 0, 0, 0.0, 0.0)
  35.       call CREATE(0.0, 0)
  36.       call SIMEND(6.0)
  37.       return
  38.       end
  39.  
  40.       subroutine deciph(i)
  41. $include:'SSSF2.H'
  42.       integer ARRIVL, STARTA, ENDACT, NEXTAC, FINAL
  43.       integer ecode, statn, rewkn
  44.       logical debugf, busy, block
  45.       real*8  defect, serial
  46.       common  ARRIVL, STARTA, ENDACT, NEXTAC, FINAL,
  47.      +  ecode, statn, rewkn, debugf, busy(3), block(3),
  48.      +  defect(3), serial
  49.  
  50.       statn = mod(i, 4)
  51.       rewkn = int(i/4)
  52.       return
  53.       end
  54.  
  55.       subroutine triggr(i)
  56. $include:'SSSF2.H'
  57.       integer ARRIVL, STARTA, ENDACT, NEXTAC, FINAL
  58.       integer ecode, statn, rewkn
  59.       logical debugf, busy, block
  60.       real*8  defect, serial
  61.       common  ARRIVL, STARTA, ENDACT, NEXTAC, FINAL,
  62.      +  ecode, statn, rewkn, debugf, busy(3), block(3),
  63.      +  defect(3), serial
  64.  
  65.       call REMVFQ(i, 1)
  66.       call SCHED(0, NEXTAC, IDE())
  67.       if (i.gt.1) call CREATE(0.0, i-1)
  68.       return
  69.       end
  70.  
  71.       subroutine unblk(i)
  72. $include:'SSSF2.H'
  73.       integer ARRIVL, STARTA, ENDACT, NEXTAC, FINAL
  74.       integer ecode, statn, rewkn
  75.       logical debugf, busy, block
  76.       real*8  defect, serial
  77.       common  ARRIVL, STARTA, ENDACT, NEXTAC, FINAL,
  78.      +  ecode, statn, rewkn, debugf, busy(3), block(3),
  79.      +  defect(3), serial
  80.  
  81.       call DISPOS
  82.       if (block(i)) then
  83.         if ((NQ(i).gt.0).and.(.not.busy(i)))
  84.      +    call triggr(i)
  85.         block(i) = .FALSE.
  86.       endif
  87.       return
  88.       end
  89.  
  90.       Program EX_0506
  91. $include:'SSSF2.H'
  92.       integer ARRIVL, STARTA, ENDACT, NEXTAC, FINAL
  93.       integer ecode, statn, rewkn
  94.       logical debugf, busy, block
  95.       real*8  defect, serial
  96.       common  ARRIVL, STARTA, ENDACT, NEXTAC, FINAL,
  97.      +  ecode, statn, rewkn, debugf, busy(3), block(3),
  98.      +  defect(3), serial
  99.       character*1 sc
  100.  
  101.       call prime
  102.    99 ecode = NEXTEV()
  103.       if (ecode.gt.0) then
  104.         goto (101, 102, 103, 104) ecode
  105.  
  106. C ARRIVL
  107.   101   continue
  108.         if (IDE().gt.0) then
  109.           i = IDE()
  110.           call unblk(i)
  111.         else
  112.  
  113.           call CREATE(EX(0.5), 0)
  114.           call SETA(1, RN(0.25, 0.05))
  115.           call SETA(2, serial)
  116.           serial = serial + 1.0
  117.           call SCHED(0, NEXTAC, 1)
  118.         endif
  119.         goto 99
  120.  
  121. C NEXTAC
  122.   104   continue
  123.         i = IDE()
  124.         call deciph(i)
  125.  
  126.         if (debugf)
  127.      +    write(*,
  128.      + '(A, F6.2, A, F2.0, A, F4.2, A, I1, A, I2, A\)')
  129.      +    ' At ', T(), ' # ', A(2), ' for ', A(1),
  130.      +    'h. to station # ', statn, ' for ', rewkn,
  131.      +    ' rework'
  132.  
  133.         if (busy(statn).or.block(statn)) then
  134.           call QUEUE(statn, 0.0)
  135.           if (debugf) write(*, '(A)')' and waits'
  136.           if ((NQ(statn).gt.4).and.(statn.gt.1))
  137.      +      block(statn - 1) = .TRUE.
  138.  
  139.         else
  140.           call SCHED(0.0, STARTA, IDE())
  141.           if (debugf) then
  142.             write(*, '(A\)') ' and processed'
  143.             read(*, '(A1)') sc
  144.             if ((sc.eq.'q').or.(sc.eq.'q')) stop
  145.           endif
  146.         endif
  147.         goto 99
  148.  
  149. C STARTA
  150.   102   continue
  151.         i = IDE()
  152.         call deciph(i)
  153.         if (debugf) write(*, '(A, F6.2, A, F2.0, A)')
  154.      +    ' At ', T(), ' #', A(2), ' starts work'
  155.         if (rewkn.eq.0) call TALLY(statn, 1.0)
  156.         busy(statn) = .TRUE.
  157.         call SCHED(A(1), ENDACT, IDE())
  158.         goto 99
  159.  
  160. C ENDACT
  161.   103   continue
  162.         i = IDE()
  163.         call deciph(i)
  164.         call TALLY(statn, 0.0)
  165.  
  166.         if (debugf) write(*, '(A, F6.2, A, F2.0, A\)')
  167.      +    ' At ', T(), ' #', A(2), ' ends work'
  168.         busy(statn) = .FALSE.
  169.         if (RA().gt.defect(statn)) then
  170.           if (statn.eq.FINAL) then
  171.             call DISPOS()
  172.             if(debugf) write(*, '(A)')' and discharged'
  173.           else
  174.  
  175.             call SETA(1, RN(0.25, 0.05))
  176.             call SCHED(0, NEXTAC, statn + 1)
  177.             if (debugf) write(*, '(A)')' and goes on'
  178.           endif
  179.         else
  180.  
  181.           call SETA(1, A(1)/2)
  182.           call SCHED(0.0, NEXTAC,
  183.      +               statn + 4*(rewkn + 1))
  184.           if (debugf) write(*, '(A)')' and recycled'
  185.         endif
  186.         if (debugf) write(*, '(A, F6.2, A, I2, A, I1)')
  187.      + ' At ', T(), ' ', NQ(statn), ' are waiting at ',
  188.      +    statn
  189.         if (NQ(statn).gt.0) call triggr(statn)
  190.         goto 99
  191.  
  192.       else
  193.  
  194.         call SUMRY(' ')
  195.         stop 'End of simulation'
  196.  
  197.       endif
  198.       end
  199.