home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / ACTION.FOR next >
Encoding:
Text File  |  1986-12-15  |  5.8 KB  |  82 lines
  1.  
  2.       SUBROUTINE ACTION                                                 0001
  3.  
  4. c    include 'tcommon.for'
  5.     %include tcommon.for
  6.  
  7. C     ...LOOP ON NUMBER OF SECONDS(STEPS) SINCE LAST TIME.              0028
  8.       DO 1999 NS=1,NSTEPS   ,ITFCTR                                     0029
  9. C     ...SUBTRACT ENERGY FOR LIFE SUPPORT.                              0030
  10.       ENERGY=ENERGY-DECR                                                0031
  11.       IF(ENERGY.LE.0.)CALL RATING(2)                                    0032
  12. C     ...CHANGE STARDATE.                                               0033
  13.       XTIME=XTIME-.01                                                   0034
  14.       IF(XTIME.LE.0.)CALL RATING(3)                                     0035
  15.       SDATE=SDATE+.01                                                   0036
  16.       NTSTPS=NTSTPS+1                                                   0037
  17. C     ...ENEMY MOVES FROM QUAD TO QUAD ONCE PER STARDAY.                0038
  18.       IF(NTSTPS.EQ.NTSTPS/100*100.AND.LEVEL.NE.1)CALL QQMOVE            0039
  19.       IF(ISHD.EQ.0)GO TO 2025                                           0040
  20.       CALL TSHUTL                                                       0041
  21. C     ...IF TRUCE, ONLY CERTAIN ACTIVITIES ALLOWED.                     0042
  22. 2025  IF(ITRUCE.EQ.1)GO TO 2150                                         0043
  23.       IS=0                                                              0044
  24. C     ...ENTERPRISE MOVEMENT ROUTINE. ON RETURN:                        0045
  25. C     .......IS=0 NORMAL RETURN                                         0046
  26. C     .......IS=1 TRAVELLING AT WARP SPEED                              0047
  27. C     .......IS=2 EXCEEDED GALACTIC LIMITS                              0048
  28.       IF(PSP.EQ.0..AND.DSP.EQ.0..AND.PDEG.EQ.DDEG)GO TO 2050            0049
  29.       CALL EPMOVE(IS)                                                   0050
  30. 2050  GO TO (2800,1999),IS                                              0051
  31.       IF(IDOCK.EQ.2)GO TO 2200                                          0052
  32. C     ...ENTERPRISE TORP FIRING ROUTINE                                 0053
  33.       IF(EFT(1,1).EQ.0..OR.EFT(1,1).GT.NTSTPS)GO TO 2100                0054
  34.       CALL EFTSUB                                                       0055
  35. C     ...ENTERPRISE PHASER FIRING ROUTINE                               0056
  36. 2100  IF(EFP(1).EQ.0..OR.EFP(1).GT.NTSTPS)GO TO 2150                    0057
  37.       CALL EFPHSR                                                       0058
  38. C     ...ENTERPRISE PULSIVE BEAMS ROUTINE                               0059
  39. 2150  IF(ETR(1).EQ.0..OR.ETR(1).GT.NTSTPS.OR.ETR(2).NE.1..AND.ITRUCE.EQ.0060
  40.      11)GO TO 2200                                                      0061
  41.       CALL EPULSE                                                       0062
  42. C     ...ENTERPRISE TRANSPORTER ROUTINE                                 0063
  43. 2200  IF(ISTAT.EQ.0)GO TO 2250                                          0064
  44.       CALL BEAM                                                         0065
  45. 2250  IF(ITRUCE.EQ.1)GO TO 2600                                         0066
  46.       JJ=0                                                              0067
  47.       DO 2260 K=2,19                                                    0068
  48.       IF(ITRMEN(K).EQ.0)GO TO 2260                                      0069
  49.       IF(ICNTL(K).EQ.1)GO TO 2260                                       0070
  50.       JJ=1                                                              0071
  51. 2260  CONTINUE                                                          0072
  52.       IF(JJ.EQ.0)GO TO 2300                                             0073
  53. C     ...ENTERPRISE TROOPS FIGHTING ROUTINE                             0074
  54.       CALL FIGHT                                                        0075
  55. 2300  IF(IGH.EQ.0)GO TO 2350                                            0076
  56. C     ...GHOSTSHIP ACTIVITIES ROUTINE                                   0077
  57.       CALL GHACTV                                                       0078
  58. 2350  IF(NTORPS.EQ.0)GO TO 2400                                         0079
  59. C     ...TORP MOVEMENT ROUTINE                                          0080
  60.       CALL TRPMV                                                        0081
  61. 2400  IF(KLNGNS.EQ.0)GO TO 2450                                         0082
  62. C     ...KLINGON ACTIVITIES ROUTINE                                     0083
  63.       CALL KLNGN                                                        0084
  64. 2450  IF(NROM.EQ.0)GO TO 2500                                           0085
  65. C     ...ROMULAN ACTIVITIES ROUTINE                                     0086
  66.       CALL ROMLN                                                        0087
  67. 2500  IF(PSP.GE.1.)GO TO 2550                                           0088
  68. C     ...COLLISION DETERMINATION ROUTINE                                0089
  69. 2600  IF(IBL(ICE,JCE).GT.0)CALL BHOLE                                   0090
  70.       CALL COLLIS                                                       0091
  71.       IF(ISTORM.EQ.0)GO TO 2550                                         0092
  72.       CALL STORM                                                        0093
  73. 2550  IF(IDOCK.EQ.1)GO TO 2900                                          0094
  74. C     ...DAMAGE REPAIR ROUTINE                                          0095
  75. 2800  CALL REPAIR                                                       0096
  76.       GO TO 1999                                                        0097
  77. C     ...ENTERPRISE DOCKING ROUTINE                                     0098
  78. 2900  CALL DOCK                                                         0099
  79. 1999  CONTINUE                                                          0100
  80.       RETURN                                                            0101
  81.       END                                                               0102
  82.