home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / PROCM.FOR < prev    next >
Encoding:
Text File  |  1986-12-15  |  24.8 KB  |  723 lines
  1.       SUBROUTINE PROCM
  2.  
  3. c    include 'tcommon.for'
  4.     %include tcommon.for
  5.  
  6.       character*8 DEFLEC,moldnm
  7.  
  8.       DATA DEFLEC/'DFLECTRS'/   
  9. C     ...PROCESS ACTIVITIES PREVIOUSLY SCHEDULED AND QUEUE THEM FOR     
  10. C     ...ACTION.      
  11.       PCT(A,B)=(B-A)/A*100.     
  12. 1     IF(ICM.EQ.99)GO TO 5000   
  13.       IF(ICM.LE.0)GO TO 5000    
  14.       CALL CHEKDG(ICM,IR)       
  15.       IF(IR.EQ.1)GO TO 998      
  16.       GO TO (3001,3002,3003,3004,3005,3006,4000,3008,3009,3010,3011,3012
  17.      1       ,3013,3014,3015,3016,3017,3018,3019,3020,3031,3033),ICM    
  18.       GO TO 5000      
  19. C     ...MUST CHECK DAMAGE INDIVDUALLY HERE AS TWO TYPES OF MOTION      
  20. C     ...INVOLVED.    
  21. 3001  IF(IDMG(1).EQ.0)GO TO 30013         
  22.       IF(XDSP.LE.PSP.OR.XDSP.LE.SIM)GO TO 30011     
  23.       WRITE(6,30019)NAMD(1)     
  24. 30019 FORMAT(1X,A10, ' DAMAGED')
  25.       WRITE(6,30119)PSP         
  26. 30119 FORMAT(' DESIRED SPEED SET TO ',F5.3)         
  27.       DSP=PSP         
  28.       DDEG=XDDEG      
  29. C     ...CHECK DAMAGE TO IMPULSE DRIVE.   
  30. 30011 IF(IDMG(2).EQ.0)GO TO 30013         
  31.       WRITE(6,30019)NAMD(2)     
  32.       DDEG=PDEG       
  33.       DSP=PSP         
  34.       WRITE(6,30119)DSP         
  35.       GO TO 998       
  36. 30013 DDEG=XDDEG      
  37.       DSP=XDSP        
  38.       IF(ITRUCE.EQ.0)GO TO 4000 
  39.       WRITE(6,33333)  
  40. 33333 FORMAT(' TRUCE BROKEN...NORMAL ACTIVITIES RESUME')      
  41.       ITRUCE=0        
  42.       GO TO 4000      
  43. C     ...SHORT RANGE SCAN. STOP TIMER FOR PRINT TIME.         
  44. 3002  IF(PSP.GE.1.)GO TO 994    
  45.       IHERE=1         
  46.       CALL SCAN       
  47.       CALL QTIME(JTIME)         
  48.       ISTART=JTIME    
  49.       GO TO 4000      
  50. C     ...LONG RANGE SCAN. STOP TIMER FOR PRINTING.  
  51. 3003  I=ICE-1         
  52.       J=ICE+1         
  53.       K=JCE-1         
  54.       L=JCE+1         
  55.       IF(I.LT.1)I=1   
  56.       IF(J.GT.NQUAD)J=NQUAD     
  57.       IF(K.LT.1)K=1   
  58.       IF(L.GT.NQUAD)L=NQUAD     
  59.       DO 30032  M=I,J 
  60.       DO 30032 N=K,L  
  61.       IGAL(M,N)=JGAL(M,N)       
  62. 30032 CONTINUE        
  63. C     CALL CPAGE      
  64.       WRITE(6,30033)ICE,JCE     
  65. 30033 FORMAT(' LONG RANGE SENSOR SCAN AROUND QUADRANT ',I2,',',I2)      
  66.       WRITE(6,30034)  
  67. 30034 FORMAT(' ---------------------------')        
  68.       N=L         
  69. 30035 N=N-1 
  70.       IF(N.LT.K)GO TO 30037     
  71.       WRITE(6,30036)(JGAL(M,N),M=I,J)     
  72. 30036 FORMAT(3(2X,I4,' :',2X))  
  73.       WRITE(6,30034)  
  74.       GO TO 30035     
  75. 30037 CALL QTIME(JTIME)         
  76.       ISTART=JTIME    
  77.       GO TO 4000      
  78. C     ...PHASER FIRING SETUP.   
  79. 3004  IF(PSP.GE.1.)GO TO 994    
  80.       EFP(1)=NTSTPS+NMEN/MEN    
  81.       EFP(2)=IDIR     
  82.       EFP(3)=PNRGY    
  83.       IF(ITRUCE.EQ.0)GO TO 4000 
  84.       WRITE(6,33333)  
  85.       ITRUCE=0        
  86.       GO TO 4000      
  87. C     ...TORPS SETUP FIRING AREA.         
  88. 3005  IF(PSP.GE.1.)GO TO 994    
  89.       M=ITFIRE+1      
  90.       ITFIRE=ITFIRE+MTORPS      
  91.       ITORP=ITORP-MTORPS        
  92.       NC=1  
  93.       NF=1  
  94.       DO 30052 J=M,ITFIRE       
  95. C     ...SLOWDOWN DUE TO CREW REDUCTION BELOW 50% NORMAL.     
  96.       EFT(J,1)=NTSTPS+NF+NMEN/MEN-1       
  97.       EFT(J,2)=DTORP(J-M+1)     
  98.       NC=NC+1         
  99.       IF(NC.LE.IETOFT)GO TO 30052         
  100.       NC=1  
  101.       NF=NF+1         
  102. 30052 CONTINUE        
  103.       IF(ITRUCE.EQ.0)GO TO 4000 
  104.       ITRUCE=0        
  105.       WRITE(6,33333)  
  106.       GO TO 4000      
  107. C     ...PULSIVE BEAMS.         
  108. 3006  IF(PSP.GE.1.)GO TO 994    
  109.       ETR(1)=NTSTPS+NMEN/MEN    
  110.       ETR(2)=IBTYP    
  111.       IF(IBTYP.EQ.1)GO TO 4000  
  112.       ETR(3)=PNRGY    
  113.       IF(ITRUCE.EQ.0)GO TO 4000 
  114.       ITRUCE=0        
  115.       WRITE(6,33333)  
  116.       GO TO 4000      
  117. C     ...STATUS REPORT.         
  118. 3008  XNRGY=ENERGY-PNRGY        
  119.       WRITE(6,30081)XTIME,XNRGY,ITORP,PSP,PDEG,DEFL,ISHNUM    
  120. 30081 FORMAT(' STATUS REPORT'/' DAYS LEFT: ',F6.2,6X,'ENERGY: ',F8.2,6X,
  121.      1       'TORPS: ',I3/' SPEED: ',F6.3,6X,'BEARING: ',F4.0,'  SHIELDS
  122.      1: ',F7.1,'  SHUTTLECRAFT ON BOARD: ',I1)      
  123. C     ...ALSO PRINT TECHNOLOGICAL IMPROVEMENTS.     
  124.       IF(DVWP.EQ.DVWP0)GO TO 2  
  125.       IXRAT=PCT(DVWP0,DVWP)     
  126.       WRITE(6,702)NAMD(1),IXRAT 
  127. 702   FORMAT(' ',A10,' ACCELERATION INCREASED ',I3,'%')       
  128. 2     IF(EWRP.EQ.EWRP0)GO TO 3  
  129.       IXRAT=-PCT(EWRP0,EWRP)    
  130.       WRITE(6,703)NAMD(1),IXRAT 
  131. 703   FORMAT(1X,A10,' EFFICIENCY INCREASED BY ',I3,'%')       
  132. 3     IF(DISTPE.EQ.DISTP0)GO TO 4         
  133.       IXRAT=PCT(DISTP0,DISTPE)  
  134.       WRITE(6,704)NAMD(3),IXRAT 
  135. 704   FORMAT(1X,A10,' EFFECTIVENESS INCREASED BY ',I3,'%')    
  136. 4     IF(ETVEL.EQ.ETVEL0)GO TO 5
  137.       WRITE(6,705)NAMD(4),ETVEL 
  138. 705   FORMAT(1X,A10,' VELOCITY INCREASED TO ',F5.3) 
  139. 5     IF(IETOFT.EQ.IETOF0)GO TO 6         
  140.       WRITE(6,706)NAMD(4),IETOFT
  141. 706   FORMAT(1X,A10,' RATE NOW ',I2,' PER STAR-MINUTE')       
  142. 6     IF(DISTGT.EQ.DISTG0)GO TO 7         
  143.       IXRAT=PCT(DISTG0,DISTGT)  
  144.       WRITE(6,704)NAMD(5),IXRAT 
  145. 7     IF(CODDS.EQ.CODDS0)GO TO 8
  146.       IXRAT=PCT(CODDS0,CODDS)   
  147.       WRITE(6,708)IXRAT         
  148. 708   FORMAT(' TROOP FIGHTING EFFECTIVENESS VS KLINGONS INCREASED BY ',I
  149.      13,'%')
  150. 8     IF(EODDS.EQ.EODDS0)GO TO 9
  151.       IXRAT=PCT(EODDS0,EODDS)   
  152.       WRITE(6,709)IXRAT         
  153. 709   FORMAT(' TROOP FIGHTING EFFECTIVENESS VS ROMULANS INCREASED BY ',I
  154.      13,'%')
  155. 9     IF(IDAMRP.EQ.IDAMR0)GO TO 14        
  156.       IXRAT=PCT(FLOAT(IDAMR0),FLOAT(IDAMRP))        
  157.       WRITE(6,706) NAMD(8),IDAMRP         
  158. 14    IF(TRNRG0.EQ.TRNRGY)GO TO 10        
  159.       IXRAT=-PCT(TRNRG0,TRNRGY) 
  160.       WRITE(6,703)NAMD(8),IXRAT 
  161. 10    IF(PJAM.EQ.PJAM0)GO TO 11 
  162.       IXRAT=-PCT(PJAM0,PJAM)    
  163.       WRITE(6,710)NAMD(9),IXRAT 
  164. 710   FORMAT(1X,A10,' INTERCEPTION PROBABILITY REDUCED BY ',I3,'%')     
  165. 11    IF(SHLDF.EQ.SHLDF0)GO TO 12         
  166.       IXRAT=PCT(SHLDF0,SHLDF)   
  167.       WRITE(6,6112)IXRAT        
  168. 6112  FORMAT(' SHIELDS IMPROVED BY ',I3,'%')        
  169. 12    IF(ICLOAK.GE.0)GO TO 13   
  170.       SDAYS=-ICLOAK/100.        
  171.       WRITE(6,7101)SDAYS        
  172. 7101  FORMAT(' CLOAKING DEVICE AVAILABLE FOR ',F5.2,' STARDAYS')        
  173. 13    CALL QTIME(ISTART)        
  174.       GO TO 4000      
  175. C     ...DAMAGE REPORT.         
  176. 3009  IF(JDAM.NE.2)GO TO 30999  
  177.       WRITE(6,30991)  
  178. 30991 FORMAT(' REPAIR CREWS REASSIGNED')  
  179. 30999 TOTAL=0.        
  180.       N=0   
  181.       DO 30992 J=1,10 
  182.       IF(JDAM.EQ.2)IPROB1(J)=IPROB2(J)    
  183.       IF(IDMG(J).EQ.0)GO TO 30992         
  184.       TOTAL=TOTAL+IPROB1(J)     
  185.       N=N+1 
  186. 30992 IPROB2(J)=0     
  187.       IF(JDAM.EQ.2)GO TO 4000   
  188.       WRITE(6,30091)  
  189. 30091 FORMAT(' DAMAGE REPORT')  
  190.       JJ=0  
  191.       IF(N.EQ.0)GO TO 37379     
  192.       DO 30092 J=1,10 
  193.       IF(IDMG(J).EQ.0)GO TO 30092         
  194.       JJ=1  
  195.       SDAYS=IDMG(J)/100. *FLOAT(NMEN)/FLOAT(MEN)    
  196.       ASSN=((100.-TOTAL)/N+IPROB1(J))/100.
  197.       JSSN=ASSN*100.  
  198.       DAYS=1.E7       
  199.       IF(ASSN.LE.0.)GO TO 39899 
  200.       DAYS=SDAYS/ASSN/ERPRRT    
  201. 39899 WRITE(6,30093)NAMD(J),DAYS,JSSN     
  202. 30093 FORMAT(1X,A8,2X,'-',F5.2,' STARDAYS',' (',I3,'%)')      
  203. 30092 CONTINUE        
  204. 37379 IF(JJ.EQ.1)GO TO 30094    
  205.       WRITE(6,30095)  
  206. 30095 FORMAT(' NO DAMAGE')      
  207. C     ...CHECK MEN KILLED.      
  208. 30094 IF(MEN.EQ.NMEN)GO TO 30099
  209.       KMEN=NMEN-MEN   
  210.       WRITE(6,30096)KMEN,MEN    
  211. 30096 FORMAT(1X,I4,' CREW KILLED - ',I4,' LEFT')    
  212. 30099 ITM=0 
  213.       DO 30098 J=1,20 
  214. 30098 ITM=ITM+ITRMEN(J)         
  215.       IF(ITM.EQ.IFGHTM)GO TO 4000         
  216.       KMEN=IFGHTM-ITM 
  217.       IF(KMEN.LT.0)KMEN=0       
  218.       WRITE(6,30097)KMEN,ITM    
  219. 30097 FORMAT(1X,I4,' TROOPS KILLED - ',I4,' LEFT')        
  220.       GO TO 4000      
  221. C     ...EVASIVE MANEUVERS.     
  222. 3010  IF(PSP.GE.1.0)GO TO 994   
  223.       DSP=EVMSP       
  224.       IF(IDMG(1).EQ.0.OR.IDMG(2).EQ.0)GO TO 30111   
  225.       IF(IDMG(1).EQ.0)GO TO 30104         
  226.       WRITE(6,30019)NAMD(1)     
  227.       IF(IDMG(2).EQ.0)GO TO 998 
  228. 30104 WRITE(6,30019)NAMD(2)     
  229.       WRITE(6,30119)SIM         
  230.       NBASES=0        
  231.       GO TO 998       
  232. 30111 IF(IEVDR.EQ.1)GO TO 30101 
  233.       IF(IEVDR.EQ.3)GO TO 30103 
  234.       PDEG=PDEG-90.   
  235.       IF(PDEG.LT.0.)PDEG=PDEG+360.        
  236.       X=EVENU         
  237.       IF(IDMG(1).NE.0)X=X*2.5   
  238.       GO TO 30102     
  239. 30101 PDEG=PDEG+90.   
  240.       X=EVENU         
  241.       IF(IDMG(1).NE.0)X=X*2.5   
  242. 30105 IF(PDEG.GE.360.)PDEG=PDEG-360. 
  243.       GO TO 30102     
  244. 30103 PDEG=PDEG+180.  
  245.       X=EVENU*1.5     
  246.       IF(IDMG(1).NE.0)X=X*2.5   
  247.       GO TO 30105     
  248. 30102 ENERGY=ENERGY-X 
  249.       IF(ENERGY.LE.0.)CALL RATING(2)      
  250.       DDEG=PDEG       
  251.       IF(ITRUCE.EQ.0)GO TO 4000 
  252.       ITRUCE=0        
  253.       WRITE(6,33333)  
  254.       GO TO 4000      
  255. C     ...EMERGENCY EVASIVE MANEUVERS.MUST USE WARP DRIVE.     
  256. 3011  IF(PSP.GE.1.)GO TO 994    
  257.       DSP=EEVMSP      
  258.       NBASES=99       
  259.       IF(IDMG(1).EQ.0)GO TO 30111         
  260.       GO TO 30104     
  261. C     ...RAISE DEFLECTORS.      
  262. 3012  IF(ADDFL.LT.-DEFL)GO TO 3013        
  263.       DEFL=DEFL+ADDFL 
  264.       ENERGY=ENERGY-ADDFL       
  265.       IF(ENERGY.LE.0.)CALL RATING(2)      
  266.       GO TO 4000      
  267. C     ...DROP DEFLECTORS.       
  268. 3013  ENERGY=ENERGY+DEFL        
  269.       WRITE(6,30131)  
  270. 30131 FORMAT(' DROP DEFLECTORS')
  271.       DEFL=0.         
  272.       GO TO 4000      
  273. C     ...PROPOSE TRUCE.         
  274. 3014  IF(PSP.GE.1.)GO TO 994    
  275.       WRITE(6,30141)  
  276. 30141 FORMAT(' TRUCE PROPOSED') 
  277.       X=0.  
  278.       Y=0.  
  279.       JJ=0  
  280.       IF(KLNGNS.EQ.0)GO TO 30143
  281.       DO 30142 J=1,KLNGNS       
  282.       IF(XKL(J,1).EQ.0.)GO TO 30142       
  283.       IF(ICNTL(J+1).EQ.1)GO TO 30142      
  284.       IF(ITRMEN(J+1).NE.0)GO TO 30146     
  285.       JJ=1  
  286.       X=X+XKL(J,7)    
  287.       Y=Y+XKLHIT      
  288. 30142 CONTINUE        
  289. 30143 IF(NROM.EQ.0)GO TO 30145  
  290.       DO 30144 J=1,NROM         
  291.       IF(XROM(J,1).EQ.0.)GO TO 30144      
  292.       IF(ICNTL(J+10).EQ.1)GO TO 30144     
  293.       IF(ITRMEN(J+10).NE.0)GO TO 30146    
  294.       JJ=1  
  295.       X=X+XROM(J,3)   
  296.       Y=Y+XRMHIT      
  297. 30144 CONTINUE        
  298. 30145 IF(JJ.EQ.0)GO TO 30146    
  299. C     ...ACCEPTED ONLY IF ALL ENEMY AT LEAST 75% DAMAGED.     
  300.       IF(RAN(IZZ).GT.(X/Y)/THITR)GO TO 30146        
  301.       WRITE(6,30147)  
  302. 30147 FORMAT(' TRUCE ACCEPTED') 
  303.       ITRUCE=1        
  304.       GO TO 4000      
  305. 30146 WRITE(6,30148)  
  306. 30148 FORMAT(' TRUCE OFFER DECLINED')     
  307.       GO TO 4000      
  308. C     ...SHORT RANGE TRACK.     
  309. 3015  IF(PSP.GE.1.)GO TO 994         
  310.       WRITE(6,30151)  
  311. 30151 FORMAT(' SHORT RANGE TRACK')        
  312.       IF(KLNGNS.EQ.0)GO TO 30154
  313.       DO 30152 J=1,KLNGNS       
  314.       IF(XKL(J,1).EQ.0.)GO TO 30152       
  315.       WRITE(6,30157)LETR(3),J,(XKL(J,K),K=1,4)      
  316. 30157 FORMAT(1X,A1,I1,' AT ',F4.1,',',F4.1,' SPEED: ',F6.3,' BEARING: ',
  317.      1F5.0) 
  318. 30153 FORMAT(1X,A1,1X,' AT ',F4.1,',',F4.1,' SPEED: ',F6.3,' BEARING: ',
  319.      1F5.0) 
  320. 30152 CONTINUE        
  321. 30154 IF(NTORPS.EQ.0)GO TO 30156
  322.       DO 30155 J=1,NTORPS       
  323.       IF(TORPS(J,1).EQ.0.)GO TO 30155     
  324.       WRITE(6,30153)LETR(7),(TORPS(J,K),K=1,4)      
  325. 30155 CONTINUE        
  326. 30156 WRITE(6,30153)LETR(2),XQE,YQE,PSP,PDEG        
  327.       IF(ISTSH.NE.99)GO TO 30174
  328.       WRITE(6,30153)LETR(12),SHX,SHY,SHVX,SHDEG     
  329. 30174 IF(IGH.EQ.0)GO TO 30159   
  330.       WRITE(6,30153)LETR(5),(GHOST(K),K=1,2),(GHOST(L),L=4,5) 
  331. 30159 CALL QTIME(ISTART)        
  332.       GO TO 4000      
  333. C     ...GALACTIC MAP DISPLAY.  
  334. C 3016  CALL CPAGE    
  335. 3016  WRITE(6,30163)  
  336. 30163 FORMAT(' GALACTIC UPDATE')
  337.       I=NQUAD+1       
  338. 30161 I=I-1 
  339.       IF(I.LT.1)GO TO 30166     
  340.       DO 30164 J=1,NQUAD        
  341.       IF(I.EQ.JCE.AND.J.EQ.ICE)GO TO 30165
  342.       IPQ(J,I)=LETR(9)
  343.       GO TO 30164     
  344. 30165 IPQ(J,I)=LETR(2)
  345. 30164 CONTINUE        
  346.       WRITE(6,30162)(IGAL(J,I),IPQ(J,I),J=1,NQUAD)  
  347. 30162 FORMAT(1X,10(I4,A1,2X))   
  348.       GO TO 30161     
  349. 30166 CALL QTIME(ISTART)
  350. c#####
  351.       GO TO 4000        
  352. C     ....PLOT BEARING.         
  353. 3017  WRITE(6,30171)  
  354. 30171 FORMAT(' PLOT BEARING')   
  355.       IF(PSP.GE.1.)GO TO 30176  
  356.       IF(NSTARS.EQ.0)GO TO 30175
  357.       DO 30172 J=1,NSTARS       
  358.       IF(STARS(J,1).EQ.0.)GO TO 30172     
  359.       CALL GETBRG(DELTA,XQE,STARS(J,1),YQE,STARS(J,2),VPX,VPY)
  360.       VSX=SQRT(VPX*VPX+VPY*VPY) 
  361.       WRITE(6,30173)LETR(1),J,STARS(J,1),STARS(J,2),DELTA,VSX ,RAD(J)   
  362. 30173 FORMAT(1X,A1,I1,' AT ',F4.1,',',F4.1,' BEARING: ',F4.0,' DISTANCE:
  363.      1 ',F4.1,' RADIUS: ',F3.2) 
  364. 30172 CONTINUE        
  365. 30175 IF(IBASE.EQ.0)GO TO 4000  
  366.       CALL GETBRG(DELTA,XQE,BASE(1),YQE,BASE(2),VPX,VPY)      
  367.       VSX=SQRT(VPX*VPX+VPY*VPY) 
  368.       WRITE(6,30180)LETR(6),BASE(1),BASE(2),DELTA,VSX   ,RADEB
  369. 30180 FORMAT(1X,A1,'  AT ',F4.1,',',F4.1,' BEARING: ',F4.0,' DISTANCE:  
  370.      1 ',F4.1,' RADIUS: ',F3.2) 
  371.       GO TO 4000      
  372. C     ...IF WARP 1 OR HIGHER, GIVE QUADRANTS OF STARBASES.    
  373. 30176 DO 30177  I=1,NQUAD       
  374.       DO 30177  J=1,NQUAD       
  375.       IF((JGAL(I,J)-JGAL(I,J)/100*100)/10.EQ.0) GO TO 30177   
  376.       WRITE(6,30178)I,J         
  377. 30178 FORMAT(' STARBASE IN QUADRANT ',I2,',',I2)    
  378. 30177 CONTINUE        
  379.       DO 38179 I=1,NQUAD        
  380.       DO 38179 J=1,NQUAD        
  381.       IF(IGAL(I,J).LT.0.OR.IBL(I,J).LE.0)GO TO 38179
  382.       WRITE(6,38174)I,J         
  383. 38174 FORMAT(' BLACK HOLE IN QUADRANT ',I2,',',I2)  
  384. 38179 CONTINUE        
  385.       GO TO 4000      
  386. C     ...SELF DESTRUCT
  387. 3018  CALL RATING(7)  
  388.       GO TO 4000      
  389. C     ...TRANSPORTERS.
  390. 3019  IF(PSP.GE.1.)GO TO 994    
  391.       IF(IFROM.EQ.LETR(3))GO TO 1391      
  392.       IF(IFROM.EQ.LETR(4))GO TO 1392      
  393.       IF(IFROM.EQ.LETR(5))GO TO 1393      
  394.       IF(IFROM.EQ.LETR(6))GO TO 1394      
  395.       IF(IFROM.NE.LETR(2))GO TO 998       
  396.       LUP=2 
  397.       GO TO 1395      
  398. 1394  LUP=6 
  399.       GO TO 1395      
  400. 1391  LUP=3 
  401.       IF(KFROM.LT.1.OR.KFROM.GT.KLNGNS)GO TO 998    
  402.       GO TO 1395      
  403. 1392  LUP=4 
  404.       IF(KFROM.LT.1.OR.KFROM.GT.NROM)GO TO 998      
  405.       GO TO 1395      
  406. 1393  LUP=5 
  407. 1395  CONTINUE        
  408.       IF(ITO.EQ.LETR(3))GO TO 13901       
  409.       IF(ITO.EQ.LETR(4))GO TO 13902       
  410.       IF(ITO.EQ.LETR(5))GO TO 13903       
  411.       IF(ITO.NE.LETR(2))GO TO 998         
  412.       LDOWN=2         
  413.       GO TO 13905     
  414. 13901 LDOWN=3         
  415.       IF(MTO.LT.1.OR.MTO.GT.KLNGNS)GO TO 998        
  416.       IF(ITRUCE.EQ.0.OR.ICNTL(MTO+1).EQ.1)GO TO 13905         
  417.       ITRUCE=0        
  418.       WRITE(6,33333)  
  419.       GO TO 13905     
  420. 13902 LDOWN=4         
  421.       IF(MTO.LT.1.OR.MTO.GT.NROM)GO TO 998
  422.       IF(ITRUCE.EQ.0.OR.ICNTL(MTO+10).EQ.1)GO TO 13905        
  423.       ITRUCE=0        
  424.       WRITE(6,33333)  
  425.       GO TO 13905     
  426. 13903 LDOWN=5         
  427. C     ...COMMAND OK NOW.        
  428. 13905 ISTAT=IBMEN     
  429.       JTO=MTO         
  430.       JFROM=KFROM     
  431.       JDOWN=LDOWN     
  432.       JUP=LUP         
  433.       GO TO 4000      
  434. C     ...OTHER SHIP ACTIVITIES UNDER E CONTROL.     
  435. 3020  IF(PSP.GE.1.)GO TO 994    
  436.       GO TO (30201,992,992,30204,30205,30206,992,30208,30209,992   ,992,
  437.      130212,992,992,992,992,30217),IMSG   
  438. C     ...K COURSE CHANGE.       
  439. 30201 IF(LTO.EQ.5)GO TO 30240   
  440.       IF(ICNTL(KTO+1).NE.1)GO TO 992      
  441.       IF(ITRMEN(KTO+1).LE.0)GO TO 992     
  442.       XKL(KTO,6)=KBRG 
  443.       XKL(KTO,5)=AMIN1(ABS(XWRP),VMXKL)   
  444.       GO TO 4000      
  445. C     ...K FIRE PHASER.         
  446. 30204 IF(LTO.EQ.5)GO TO 30250   
  447.       IF(ICNTL(KTO+1).NE.1)GO TO 992      
  448.       IF(ITRMEN(KTO+1).LE.0)GO TO 992     
  449.       XKL(KTO,8)=NTSTPS+1+(CREWK/ITRMEN(KTO+1)*SKDLAY+RAN      (IZZ)*XKF
  450.      1PST)  
  451.       GO TO 4000      
  452. C     ...R FIRE TORPEDO.        
  453. 30205 IF(LTO.EQ.5)GO TO 30260   
  454.       IF(ICNTL(KTO+10).NE.1)GO TO 992     
  455.       IF(ITRMEN(KTO+10).LE.0)GO TO 992    
  456.       XROM(KTO,4)=NTSTPS+1+(SCREWR/ITRMEN(KTO+10)*SRDLY+RAN      (IZZ)*X
  457.      1RFTS)*XRMHIT/(XRMHIT-XROM(KTO,3))   
  458. c$$
  459.       GO TO 4000      
  460. C     ...SCUTTLE SHIP 
  461. C     ...JJSTAT=0 NORMAL        
  462. C     ...JJSTAT < 0 TRANSPORTERS QUEUED FOR USE BY AUTO-DESTRUCT.       
  463. C     ...JJSTAT > 0 TRANSPORTERS CURRENTLY IN USE FOR AUTO-DESTRUCT.    
  464. 30206 L=LTO-2         
  465.       IF(LTO.EQ.5)KTO=1         
  466.       M=(L-1)*9+KTO+1 
  467.       IF(ICNTL(M).NE.1)GO TO 992
  468.       IF(ITRMEN(M).EQ.0)GO TO 992         
  469.       IF(JJSTAT.NE.0)GO TO 39299
  470.       SDAYS=0.        
  471.       IF(ISTAT.EQ.0)GO TO 39200 
  472. C     ...TRANSPORTERS IN USE. SET UP JJSTAT TO INDICATE WE ARE WAITNG.  
  473.       JJSTAT=-ISTAT/(IDAMRP+1)-1
  474.       GO TO 39202     
  475. 39200 ISTAT=ITRMEN(M) 
  476.       JJSTAT=1        
  477.       JFROM=KTO       
  478.       JUP=LTO         
  479.       JDOWN=2         
  480.       JTO=1 
  481.       SDAYS=(ISTAT/(IDAMRP+1)+1)/100.     
  482.       GO TO 39204     
  483. 39202 SDAYS=SDAYS-JJSTAT/100.   
  484.       JJFROM=KTO      
  485.       JJUP=LTO        
  486.       JJDOWN=2        
  487.       JJTO=1
  488.       SDAYS=SDAYS+(ITRMEN(M)/(IDAMRP+1)+1)/100.     
  489.       IISTAT=ITRMEN(M)
  490. 39204 WRITE(6,39203)SDAYS       
  491. 39203 FORMAT(' DESTRUCT IN ',F5.2,' STARDAYS')      
  492.       GO TO 4000      
  493. 39299 WRITE(6,39298)LETR(JUP),JFROM       
  494. 39298 FORMAT(' RETYPE COMMAND WHEN ',A1,I1,' DESTRUCT SEQUENCE COMPLETED
  495.      1')    
  496.       GO TO 998       
  497. C     ...STATUS REPORT
  498. 30208 IF(LTO.EQ.6)GO TO 30299   
  499.       LTO=LTO-2       
  500.       GO TO (30281,30285,30288),LTO       
  501. C     ...KLINGON STATUS         
  502. 30281 IF(ICNTL(KTO+1).NE.1)GO TO 992      
  503.       WRITE(6,30282)LETR(3),KTO,(XKL(KTO,J),J=1,4),ITRMEN(KTO+1)        
  504. 30282 FORMAT(' STATUS REPORT FOR ',A1,I1,' AT ',F4.1,',',F4.1/      ' SP
  505.      1EED: ',F5.3,' BEARING: ',F4.0,' MEN ON BOARD: ',I5)     
  506.       GO TO 4000      
  507. C     ...ROMULAN STATUS         
  508. 30285 IF(ICNTL(KTO+10).NE.1)GO TO 992     
  509.       WRITE(6,30283)LETR(4),KTO,XROM(KTO,1),XROM(KTO,2),ITRMEN(KTO+10)  
  510. 30283 FORMAT(' STATUS REPORT FOR ',A1,I1,' AT ',F4.1,',',F4.1/      ' ME
  511.      1N ON BOARD: ',I5)         
  512.       GO TO 4000      
  513. C     ...GHOSTSHIP STATUS       
  514. 30288 IF(IGH.EQ.0)GO TO 992     
  515.       IF(ICNTL(20).NE.1)GO TO 992         
  516.       WRITE(6,30284)LETR(5),GHOST(1),GHOST(2),GHOST(4),GHOST(5),      (G
  517.      1HOST(K),K=11,13),ITRMEN(20)         
  518. 30284 FORMAT(' STATUS REPORT FOR ',A1,' AT ',F4.1,',',F4.1/      ' SPEED
  519.      1: ',F5.3,' BEARING: ',F4.0,' ENERGY: ',F7.1,      ' TORPS: ',F3.0/
  520.      1' SHIELD STRENGTH: ',F6.1,' MEN ON BOARD: ',I5)         
  521.       GO TO 4000      
  522. C     ...DAMAGE REPORT
  523. 30209 LTO=LTO-2       
  524.       GO TO (30291,30295,30298),LTO       
  525. C     ...KLINGON DAMAGE         
  526. 30291 IF(ICNTL(KTO+1).NE.1)GO TO 992      
  527.       WRITE(6,30292)LETR(3),KTO,XKL(KTO,7)
  528. 30292 FORMAT(' DAMAGE REPORT FOR ',A1,I1,' HITS: ',F5.1)      
  529.       GO TO 4000      
  530. C     ...ROMULAN DAMAGE         
  531. 30295 IF(ICNTL(KTO+10).NE.1)GO TO 992     
  532.       WRITE(6,30292)LETR(4),KTO,XROM(KTO,3)         
  533.       GO TO 4000      
  534. C     ...GHOSTSHIP DAMAGE       
  535. 30298 IF(IGH.EQ.0)GO TO 992     
  536.       IF(ICNTL(20).NE.1)GO TO 992         
  537.       WRITE(6,30292)LETR(5),IGH,GHOST(3)  
  538. 3991  IF(IGHPH.EQ.0)WRITE(6,30293)NAMD(3) 
  539. 30293 FORMAT(1X,A10,' DEAD')    
  540. 3992  IF(IGHTR.EQ.0)WRITE(6,30293)NAMD(4) 
  541. 3993  IF(IGHDR.EQ.0)WRITE(6,30293)NAMD(2) 
  542. 3994  IF(IGHDE.EQ.0)WRITE(6,30293)DEFLEC  
  543.       GO TO 4000      
  544. C     ...G RAISE DEFLECTORS.    
  545. 30212 IF(ICNTL(20).NE.1)GO TO 992         
  546.       IF(IGHDE.EQ.0)GO TO 3994  
  547.       IF(SDEF)30213,992,30214   
  548. C     ...DROP         
  549. 30213 SDEF=AMAX1(SDEF,-GHOST(13))         
  550. 30215 GHOST(13)=GHOST(13)+SDEF  
  551.       GHOST(11)=GHOST(11)-SDEF  
  552.       GO TO 4000      
  553. C     ...RAISE        
  554. 30214 SDEF=AMIN1(SDEF,GHOST(11))
  555.       GO TO 30215     
  556. C     ...CHANGE COURSE
  557. 30240 IF(ICNTL(20).NE.1)GO TO 992         
  558.       IF(ITRMEN(20).LE.0)GO TO 992        
  559.       IF(IGHDR.EQ.0)GO TO 3993  
  560.       GHOST(6)=AMIN1(XWRP,GHVMX)
  561.       GHOST(7)=KBRG   
  562.       GO TO 4000      
  563. C     ...G FIRE P.    
  564. 30250 IF(ICNTL(20).NE.1)GO TO 992         
  565.       IF(ITRMEN(20).LE.0)GO TO 992        
  566.       IF(IGHPH.EQ.0)GO TO 3991  
  567.       GHOST(10)=NTSTPS+1+FLOAT(MIN0(MXCRGH,ITRMEN(20)))/      FLOAT(ITRM
  568.      1EN(20))         
  569.       GO TO 4000      
  570. C     ...G FIRE T.    
  571. 30260 IF(ICNTL(20).NE.1)GO TO 992         
  572.       IF(ITRMEN(20).LE.0)GO TO 992        
  573.       IF(IGHTR.EQ.0)GO TO 3992  
  574.       GHOST(8)=NTSTPS+1+FLOAT(MIN0(MXCRGH,ITRMEN(20)))/      FLOAT(ITRME
  575.      1N(20))
  576.       GO TO 4000      
  577. C     ...COMMUNICATION WITH B.  
  578. 30299 IF(IBASE.EQ.0)GO TO 992   
  579.       WRITE(6,30294)IBMENR      
  580. 30294 FORMAT(' STARBASE TROOPS AVAILABLE: ',I4)     
  581.       GO TO 4000      
  582. C     ...PLOT BEARING FROM BASE.
  583. 30217 IF(IBASE.EQ.0)GO TO 992   
  584.       WRITE(6,30171)  
  585.       IF(NSTARS.EQ.0)GO TO 30218
  586.       DO 30219 J=1,NSTARS       
  587.       IF(STARS(J,1).EQ.0.)GO TO 30219     
  588.       CALL GETBRG(DELTA,BASE(1),STARS(J,1),BASE(2),STARS(J,2),VPX,VPY)  
  589.       VSX=SQRT(VPX*VPX+VPY*VPY) 
  590.       WRITE(6,30173)LETR(1),J,STARS(J,1),STARS(J,2),DELTA,VSX ,RAD(J)   
  591. 30219 CONTINUE        
  592. 30218 CALL GETBRG(DELTA,BASE(1),XQE,BASE(2),YQE,VPX,VPY)      
  593.       VSX=SQRT(VPX*VPX+VPY*VPY) 
  594.       WRITE(6,30180)LETR(2),XQE,YQE,DELTA,VSX,RADEB 
  595.       GO TO 4000      
  596. C     ...SHUTTLECRAFT ACTIVITIES.         
  597. 3031  IF(PSP.GE.1.)GO TO 994    
  598.       IF(ISHNUM.LE.0)GO TO 30314
  599.       GO TO (30310,30315),JSCHM 
  600. C     ...EXPLORE.     
  601. 30310 IF(ISHSTR(1).GT.NSTARS.OR.ISHSTR(1).LE.0)GO TO 998      
  602.       IF(STARS(ISHSTR(1),1).EQ.0.)GO TO 998         
  603.       ISHD=ISHSTR(1)  
  604.       IF(ISTSH.NE.99)GO TO 4000 
  605.       SDAYS=RANGE(SHX,STARS(ISHSTR(1),1),SHY,STARS(ISHSTR(1),2))/SHVX/10
  606.      10.    
  607.       WRITE(6,30313)SDAYS       
  608. 30313 FORMAT(' ARRIVAL IN ',F4.2,' STARDAYS')       
  609.       GO TO 4000      
  610. C     ...RETURN       
  611. 30314 WRITE(6,30311)  
  612. 30311 FORMAT(' NO SHUTTLECRAFT ON BOARD') 
  613.       GO TO 998       
  614. 30315 IF(ISTSH.EQ.0)GO TO 998   
  615.       ISHD=99         
  616.       IF(ISTSH.NE.99)GO TO 4000 
  617.       SDAYS=RANGE(SHX,XQE,SHY,YQE)/100./SHVX        
  618.       WRITE(6,30313)SDAYS       
  619.       GO TO 4000      
  620. C     ...COMPUTER REQUESTS.     
  621. 3033  IF(PSP.GE.1.)GO TO 994    
  622.       GO TO (30331,30334,30338,30340,30370,30360),JSCHM       
  623.       GO TO 998       
  624. C     ...ENERGY FOR G.
  625. 30331 IF(IGH.EQ.0)GO TO 992     
  626.       X=(GHOST(1)-XQE)**2+(GHOST(2)-YQE)**2         
  627.       X=X/DISTGT*PTRGH
  628.       WRITE(6,30332)X 
  629. 30332 FORMAT(F8.0,' UNITS ENERGY REQUIRED')         
  630.       GO TO 4000      
  631. C     ...WHERE HOLE WILL TAKE YOU.        
  632. 30334 IF(IHOLE.EQ.0)GO TO 992   
  633.       I=IBL(ICE,JCE)/100        
  634.       J=IBL(ICE,JCE)-I*100      
  635.       WRITE(6,30335)I,J         
  636. 30335 FORMAT(' HOLE GOES TO QUADRANT ',I2,',',I2)   
  637.       GO TO 4000      
  638. C     ...SHUTTLECRAFT ROUND TRIP TIME.    
  639. 30338 IF(ISTSH.EQ.99)GO TO 30350
  640.       DO 30351 I=1,9  
  641.       IF (ISTSH.EQ.I)GO TO 30350
  642. 30351 CONTINUE        
  643.       IF(ISHSTR(1).LE.0.OR.NSTARS.EQ.0)GO TO 992    
  644. 30350 JTIME=0         
  645.       Y=SHX 
  646.       Z=SHY 
  647.       IF(ISHD.ne.99)go to 100
  648.     X=RANGE(Y,XQE,Z,YQE)      
  649.       JTIME=JTIME+X/SHVX        
  650.     go to 30336
  651. 100    continue
  652.       DO 30339 I=1,10 
  653.       J=ISHSTR(I)     
  654.       IF(J.LE.0)GO TO 30333     
  655.       IF(STARS(J,1).EQ.0.)GO TO 30333     
  656.       X=RANGE(Y,STARS(J,1),Z,STARS(J,2))  
  657.       Y=STARS(J,1)    
  658.       Z=STARS(J,2)    
  659.       JTIME=JTIME+X/SHVX        
  660.       GO TO 30339     
  661. 30333 X=RANGE(Y,XQE,Z,YQE)      
  662.       JTIME=JTIME+X/SHVX        
  663.       GO TO 30336     
  664. 30339 CONTINUE        
  665.       GO TO 992       
  666. 30336 WRITE(6,30337)JTIME       
  667. 30337 FORMAT(' ROUND TRIP TIME = ',I4,' STARMINUTES')         
  668.       GO TO 4000      
  669. 30340 CALL CPAGE      
  670.       IIKK=0
  671.       WRITE(6,30341)  
  672. 30341 FORMAT(' COMMUNIQUE FROM STARFLEET COMMAND! '/'  THE CURRENT RANKS
  673.      1 HAVE BEEN OBTAINED BY THE FOLLOWING OFFICERS:')        
  674. 30342 IRNK=14         
  675.       IIKK=IIKK+1     
  676.       READ(3,REC=IIKK,ERR=30347)MNAME,POINTS,MPASS,X6,X7    
  677.       IF(MNAME.EQ.MOLDNM)GO TO 30347      
  678.       MOLDNM=MNAME    
  679. 30344 IF(POINTS.GE.RANKPT(IRNK))GO TO 30345         
  680.       IRNK=IRNK-1     
  681.       GO TO 30344     
  682. 30345 WRITE(6,30346)RANKS(1,IRNK),RANKS(2,IRNK),MNAME,POINTS  
  683. 30346 FORMAT(2A8,' ',A8,' CURRENTLY HAS POINTS = ',F6.2)      
  684.       GO TO 30342     
  685. 30347 READ(3,REC=MMKEY,ERR=4000)MNAME,POINTS,MPASS,X6,X7    
  686.       GO TO 4000      
  687. 30370 ION=0 
  688.       IF(ICLKON.EQ.IYES)ION=1   
  689.       GO TO 4000      
  690. 30360 CALL QTIME(ITC) 
  691.       ITM1=ITC/3600   
  692.       ITC=ITC-ITM1*3600         
  693.       ITM2=ITC/60     
  694.       ITM3=ITC-ITM2*60
  695.       WRITE(6,30361)ITM1,ITM2,ITM3        
  696. 30361 FORMAT(' CURRENT TIME FROM COMPUTER BANKS: ',I2,':',I2,':',I2)    
  697.       GO TO 4000      
  698. C     ...CANCELLED COMMAND DUE TO ILLEGAL REQUEST VALUE OR CHANGE IN    
  699. C     ...SYSTEM STATUS.         
  700. 998   WRITE(6,996)    
  701.       IF(ICM.EQ.6)ETR(1)=0.     
  702.       IF(ICM.EQ.5)EFT(1,1)=0.   
  703.       IF(ICM.EQ.4)EFP(1)=0.     
  704.       PNRGY=0.        
  705. 996   FORMAT(' ***CANCELLED***')
  706.       GO TO 4000      
  707. C     ...ILLEGAL COMMAND AREA.  
  708. 994   WRITE(6,993)    
  709.       IF(ICM.GE.4.AND.ICM.LE.6)GO TO 998  
  710. 993   FORMAT(' IMPOSSIBLE - HYPERSPACE!') 
  711.       GO TO 4000      
  712. C     ...NEW ONE HERE.
  713. 992   WRITE(6,991)    
  714. 991   FORMAT(' NOT UNDER E CONTROL OR OTHERWISE IMPOSSIBLE')  
  715. C     ...FINISH UP.   
  716. 4000  CALL QTIME(JTIME)         
  717.       NSTEPS=(JTIME-ISTART)+ITRSTP*ITFCTR 
  718.       ISTART=JTIME    
  719.       ITRSTP=0        
  720.       IF(NSTEPS.LE.0)NSTEPS=1   
  721. 5000  RETURN
  722.       END
  723.