home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / EPULSE.FOR < prev    next >
Encoding:
Text File  |  1986-12-15  |  6.0 KB  |  83 lines
  1.       SUBROUTINE EPULSE                                                 1638
  2.  
  3. c    include 'tcommon.for'
  4.     %include tcommon.for
  5.  
  6. C     ...PULSIVE BEAMS.                                                 1661
  7. 2400  EFP(1)=0.                                                         1662
  8.       CALL CHEKDG(6,IR)                                                 1663
  9.       IF(IR.EQ.1)GO TO 2490                                             1664
  10.       IF(ETR(2).NE.1.)GO TO 2450                                        1665
  11. C     ...COMPUTER CALCULATES STRENGTH TO PULL IN G.                     1666
  12.       IF(IGH.NE.0)GO TO 2402                                            1667
  13.       WRITE(6,2401)LETR(5)                                              1668
  14. 2401  FORMAT(' NO ',A1,' IN QUADRANT')                                  1669
  15.       PNRGY=0.                                                          1670
  16.       WRITE(6,2403)                                                     1671
  17. 2403  FORMAT(' PULSIVE BEAMS TURNED OFF')                               1672
  18.       GO TO 2500                                                        1673
  19. 2402  DELV=(GHOST(1)-XQE)**2+(GHOST(2)-YQE)**2                          1674
  20.       DELV=DELV/DISTGT*PTRGH                                            1675
  21.       ENERGY=ENERGY-DELV                                                1676
  22.       WRITE(6,2407)LETR(5),IGH,GHOST(1),GHOST(2)                        1677
  23. 2407  FORMAT(' PULSIVE BEAMS LOCKED ON ',A1,I1, ' AT ',F4.1,',',F4.1)   1678
  24.       IF(ENERGY.LE.0.)CALL RATING(2)                                    1679
  25.       IF(DEFL.NE.0.)GO TO 2410                                          1680
  26.       WRITE(6,2404)                                                     1681
  27. 2404  FORMAT(' DOCKED WITH GHOSTSHIP!')                                 1682
  28. C     ...PART OF ENERGY MAY BE LOST DUE TO PHASER HITS.                 1683
  29.       ENERGY=ENERGY+GHOST(11)+GHOST(13)-GHOST(3)                        1684
  30.       ITORP=ITORP+GHOST(12)                                             1685
  31.       ITRMEN(1)=ITRMEN(1)+ITRMEN(20)                                    1686
  32.       ITRMEN(20)=0                                                      1687
  33.       WRITE(6,2405)ENERGY,ITORP                                         1688
  34. 2405  FORMAT(' ENERGY = ',F8.2,' TORPEDOS - ',I2)                       1689
  35.       IGH=0                                                             1690
  36.       GO TO 2500                                                        1691
  37. C     ...SHELDS NOT DOWN IMPLIES COLLISION.                             1692
  38. 2410  WRITE(6,2153)LETR(2),LETR(5)                                      1693
  39. 2153  FORMAT(1X,A1,' COLLISION WITH ',A1)                               1694
  40.       WRITE(6,2154)                                                     1695
  41. 2154  FORMAT(' SHIELDS DESTROYED')                                      1696
  42.       CALL DLETE(5,0)                                                   1697
  43.       CALL DAMAGE(0,DEFL)                                               1698
  44.       GO TO 2500                                                        1699
  45. C     ...LOCK ON NEAREST K FOR R BEAMS.                                 1700
  46. 2450  ETR(1)=0.                                                         1701
  47.       IF(KLNGNS.NE.0)GO TO 2460                                         1702
  48. 2455  WRITE(6,2401)LETR(3)                                              1703
  49.       WRITE(6,2403)                                                     1704
  50.       PNRGY=0.                                                          1705
  51.       ETR(1)=0.                                                         1706
  52.       GO TO 2500                                                        1707
  53. 2460  PNRGY=0.                                                          1708
  54.       JJ=-ETR(2)                                                        1709
  55.       IF(XKL(JJ,1).EQ.0.)GO TO 2455                                     1710
  56.       DELV=(XQE-XKL(JJ,1))**2+(YQE-XKL(JJ,2))**2                        1711
  57.       WRITE(6,2407)LETR(3),JJ,XKL(JJ,1),XKL(JJ,2)                       1712
  58.       ENERGY=ENERGY-ETR(3)                                              1713
  59.       IF(ENERGY.LE.0.)CALL RATING(2)                                    1714
  60.       DELV=DISTKR/DELV*ETR(3)/PRKLN                                     1715
  61. C     ...MOVE K. REDUCE SPEED ACCORDINGLY.                              1716
  62.       CALL GETBRG(DELTA,XQE,XKL(JJ,1),YQE,XKL(JJ,2),VPX,VPY)            1717
  63.       VPX=COSD(DELTA)*DELV                                              1718
  64.       VPY=SIND(DELTA)*DELV                                              1719
  65.       DELTA=ABS(DELV)/VRKL                                              1720
  66.       XKL(JJ,1)=XKL(JJ,1)+VPX                                           1721
  67.       XKL(JJ,2)=XKL(JJ,2)+VPY                                           1722
  68.       XKL(JJ,3)=XKL(JJ,3)-DELTA                                         1723
  69.       IF(XKL(JJ,3).LT.0.)XKL(JJ,3)=0.                                   1724
  70. C     ...CHECK IF FORCED OUT OF QUADRANT.                               1725
  71.       CALL KLQ(JJ,IR)                                                   1726
  72.       IF(IR.GE.1)GO TO 2500                                             1727
  73. C     ...PRINT APPROPRIATE MESSAGE.                                     1728
  74.       WRITE(6,2471)LETR(3),JJ,(XKL(JJ,KK),KK=1,4)                       1729
  75. 2471  FORMAT(1X,A1,I1,' MOVED TO ',F4.1,',',F4.1,' SPEED: ',F5.3,       1730
  76.      1             ' BEARING: ',F4.0)                                   1731
  77.       GO TO 2500                                                        1732
  78. C     ...UBIQUITOUS DAMAGE CONTROL.                                     1733
  79. 2490  PNRGY=0.                                                          1734
  80. 2500  ETR(1)=0.                                                         1735
  81.       RETURN                                                            1736
  82.       END                                                               1737
  83.